Imported Upstream version 4.00.0~~dev15+12379

diff --git a/.cvsignore b/.cvsignore
deleted file mode 100644 (file)
index e90edd4..0000000
--- a/.cvsignore
+++ /dev/null
@@ -1,19 +0,0 @@
-.depend
-configure
-ocamlc
-ocamlc.opt
-expunge
-ocaml
-ocamlopt
-ocamlopt.opt
-ocamlcomp.sh
-ocamlcompopt.sh
-package-macosx
-.DS_Store
-*.annot
-_boot_log1
-_boot_log2
-_build
-_log
-myocamlbuild_config.ml
-ocamlnat

diff --git a/.depend b/.depend
index 2c1a7958c48ff641b93d2f8664cdcfb67850c472..b64c1e797c52efe8efaf123a30aa7639edfcb17a 100644 (file)
--- a/.depend
+++ b/.depend
@@ -1,774 +1,806 @@
-utils/ccomp.cmi:
-utils/clflags.cmi:
-utils/config.cmi:
-utils/consistbl.cmi:
-utils/misc.cmi:
-utils/tbl.cmi:
-utils/terminfo.cmi:
-utils/warnings.cmi:
-utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmi \
+utils/ccomp.cmi :
+utils/clflags.cmi :
+utils/config.cmi :
+utils/consistbl.cmi :
+utils/misc.cmi :
+utils/tbl.cmi :
+utils/terminfo.cmi :
+utils/warnings.cmi :
+utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \
     utils/ccomp.cmi
-utils/ccomp.cmx: utils/misc.cmx utils/config.cmx utils/clflags.cmx \
+utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \
     utils/ccomp.cmi
-utils/clflags.cmo: utils/config.cmi utils/clflags.cmi
-utils/clflags.cmx: utils/config.cmx utils/clflags.cmi
-utils/config.cmo: utils/config.cmi
-utils/config.cmx: utils/config.cmi
-utils/consistbl.cmo: utils/consistbl.cmi
-utils/consistbl.cmx: utils/consistbl.cmi
-utils/misc.cmo: utils/misc.cmi
-utils/misc.cmx: utils/misc.cmi
-utils/tbl.cmo: utils/tbl.cmi
-utils/tbl.cmx: utils/tbl.cmi
-utils/terminfo.cmo: utils/terminfo.cmi
-utils/terminfo.cmx: utils/terminfo.cmi
-utils/warnings.cmo: utils/warnings.cmi
-utils/warnings.cmx: utils/warnings.cmi
-parsing/asttypes.cmi:
-parsing/lexer.cmi: parsing/parser.cmi parsing/location.cmi
-parsing/linenum.cmi:
-parsing/location.cmi: utils/warnings.cmi
-parsing/longident.cmi:
-parsing/parse.cmi: parsing/parsetree.cmi
-parsing/parser.cmi: parsing/parsetree.cmi
-parsing/parsetree.cmi: parsing/longident.cmi parsing/location.cmi \
+utils/clflags.cmo : utils/config.cmi utils/clflags.cmi
+utils/clflags.cmx : utils/config.cmx utils/clflags.cmi
+utils/config.cmo : utils/config.cmi
+utils/config.cmx : utils/config.cmi
+utils/consistbl.cmo : utils/consistbl.cmi
+utils/consistbl.cmx : utils/consistbl.cmi
+utils/misc.cmo : utils/misc.cmi
+utils/misc.cmx : utils/misc.cmi
+utils/tbl.cmo : utils/tbl.cmi
+utils/tbl.cmx : utils/tbl.cmi
+utils/terminfo.cmo : utils/terminfo.cmi
+utils/terminfo.cmx : utils/terminfo.cmi
+utils/warnings.cmo : utils/warnings.cmi
+utils/warnings.cmx : utils/warnings.cmi
+parsing/asttypes.cmi :
+parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi
+parsing/location.cmi : utils/warnings.cmi
+parsing/longident.cmi :
+parsing/parse.cmi : parsing/parsetree.cmi
+parsing/parser.cmi : parsing/parsetree.cmi
+parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \
     parsing/asttypes.cmi
-parsing/printast.cmi: parsing/parsetree.cmi
-parsing/syntaxerr.cmi: parsing/location.cmi
-parsing/lexer.cmo: utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
+parsing/printast.cmi : parsing/parsetree.cmi
+parsing/syntaxerr.cmi : parsing/location.cmi
+parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \
     parsing/location.cmi parsing/lexer.cmi
-parsing/lexer.cmx: utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
+parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \
     parsing/location.cmx parsing/lexer.cmi
-parsing/linenum.cmo: utils/misc.cmi parsing/linenum.cmi
-parsing/linenum.cmx: utils/misc.cmx parsing/linenum.cmi
-parsing/location.cmo: utils/warnings.cmi utils/terminfo.cmi \
-    parsing/linenum.cmi parsing/location.cmi
-parsing/location.cmx: utils/warnings.cmx utils/terminfo.cmx \
-    parsing/linenum.cmx parsing/location.cmi
-parsing/longident.cmo: utils/misc.cmi parsing/longident.cmi
-parsing/longident.cmx: utils/misc.cmx parsing/longident.cmi
-parsing/parse.cmo: parsing/syntaxerr.cmi parsing/parser.cmi \
+parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \
+    parsing/location.cmi
+parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \
+    parsing/location.cmi
+parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi
+parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi
+parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \
     parsing/location.cmi parsing/lexer.cmi parsing/parse.cmi
-parsing/parse.cmx: parsing/syntaxerr.cmx parsing/parser.cmx \
+parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \
     parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi
-parsing/parser.cmo: parsing/syntaxerr.cmi parsing/parsetree.cmi \
+parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
     parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \
     parsing/asttypes.cmi parsing/parser.cmi
-parsing/parser.cmx: parsing/syntaxerr.cmx parsing/parsetree.cmi \
+parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \
     parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \
     parsing/asttypes.cmi parsing/parser.cmi
-parsing/printast.cmo: parsing/parsetree.cmi parsing/longident.cmi \
+parsing/printast.cmo : parsing/parsetree.cmi parsing/longident.cmi \
     parsing/location.cmi parsing/asttypes.cmi parsing/printast.cmi
-parsing/printast.cmx: parsing/parsetree.cmi parsing/longident.cmx \
+parsing/printast.cmx : parsing/parsetree.cmi parsing/longident.cmx \
     parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi
-parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi
-parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi
-typing/annot.cmi: parsing/location.cmi
-typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
-typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \
-    typing/env.cmi parsing/asttypes.cmi
-typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
-typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \
-    typing/ident.cmi utils/consistbl.cmi typing/annot.cmi
-typing/ident.cmi:
-typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \
-    typing/ctype.cmi
-typing/includecore.cmi: typing/types.cmi typing/typedtree.cmi \
+parsing/syntaxerr.cmo : parsing/location.cmi parsing/syntaxerr.cmi
+parsing/syntaxerr.cmx : parsing/location.cmx parsing/syntaxerr.cmi
+typing/annot.cmi : parsing/location.cmi
+typing/btype.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi
+typing/ctype.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
+    typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
+typing/datarepr.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi
+typing/env.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+    utils/consistbl.cmi typing/annot.cmi
+typing/ident.cmi :
+typing/includeclass.cmi : typing/types.cmi typing/typedtree.cmi \
+    typing/env.cmi typing/ctype.cmi
+typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \
     typing/ident.cmi typing/env.cmi
-typing/includemod.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \
-    typing/includecore.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi
-typing/mtype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \
+typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \
+    typing/path.cmi typing/includecore.cmi typing/ident.cmi typing/env.cmi \
+    typing/ctype.cmi
+typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \
     typing/env.cmi
-typing/oprint.cmi: typing/outcometree.cmi
-typing/outcometree.cmi: parsing/asttypes.cmi
-typing/parmatch.cmi: typing/types.cmi typing/typedtree.cmi \
-    parsing/location.cmi typing/env.cmi
-typing/path.cmi: typing/ident.cmi
-typing/predef.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi
-typing/primitive.cmi:
-typing/printtyp.cmi: typing/types.cmi typing/path.cmi typing/outcometree.cmi \
-    parsing/longident.cmi typing/ident.cmi
-typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi
-typing/subst.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi
-typing/typeclass.cmi: typing/types.cmi typing/typedtree.cmi \
+typing/oprint.cmi : typing/outcometree.cmi
+typing/outcometree.cmi : parsing/asttypes.cmi
+typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
+    parsing/parsetree.cmi parsing/location.cmi typing/env.cmi
+typing/path.cmi : typing/ident.cmi
+typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
+typing/primitive.cmi :
+typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
+    typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi
+typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
+    typing/annot.cmi
+typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
+typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
-typing/typecore.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \
+typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi
-typing/typedecl.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
+typing/typedecl.cmi : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
     parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \
     typing/ident.cmi typing/env.cmi
-typing/typedtree.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \
+typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
     parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
-typing/typemod.cmi: typing/types.cmi typing/typedtree.cmi \
+typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/includemod.cmi typing/ident.cmi typing/env.cmi
-typing/types.cmi: typing/primitive.cmi typing/path.cmi typing/ident.cmi \
+typing/types.cmi : typing/primitive.cmi typing/path.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
     parsing/asttypes.cmi
-typing/typetexp.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
+typing/typetexp.cmi : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
     parsing/longident.cmi parsing/location.cmi typing/env.cmi
-typing/unused_var.cmi: parsing/parsetree.cmi
-typing/btype.cmo: typing/types.cmi typing/path.cmi utils/misc.cmi \
+typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \
     typing/btype.cmi
-typing/btype.cmx: typing/types.cmx typing/path.cmx utils/misc.cmx \
+typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \
     typing/btype.cmi
-typing/ctype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \
-    utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/ctype.cmi
-typing/ctype.cmx: typing/types.cmx typing/subst.cmx typing/path.cmx \
-    utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/ctype.cmi
-typing/datarepr.cmo: typing/types.cmi typing/predef.cmi utils/misc.cmi \
-    parsing/asttypes.cmi typing/datarepr.cmi
-typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \
-    parsing/asttypes.cmi typing/datarepr.cmi
-typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \
-    typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
-    typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
+typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \
+    utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
+    typing/ident.cmi typing/env.cmi utils/clflags.cmi typing/btype.cmi \
+    parsing/asttypes.cmi typing/ctype.cmi
+typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \
+    utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
+    typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \
+    parsing/asttypes.cmi typing/ctype.cmi
+typing/datarepr.cmo : typing/types.cmi typing/predef.cmi utils/misc.cmi \
+    typing/btype.cmi parsing/asttypes.cmi typing/datarepr.cmi
+typing/datarepr.cmx : typing/types.cmx typing/predef.cmx utils/misc.cmx \
+    typing/btype.cmx parsing/asttypes.cmi typing/datarepr.cmi
+typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
+    typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+    typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
     utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
     typing/env.cmi
-typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \
-    typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
-    typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
+typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
+    typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
+    parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
+    typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
     utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
     typing/env.cmi
-typing/ident.cmo: typing/ident.cmi
-typing/ident.cmx: typing/ident.cmi
-typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \
+typing/ident.cmo : typing/ident.cmi
+typing/ident.cmx : typing/ident.cmi
+typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \
     typing/ctype.cmi typing/includeclass.cmi
-typing/includeclass.cmx: typing/types.cmx typing/printtyp.cmx \
+typing/includeclass.cmx : typing/types.cmx typing/printtyp.cmx \
     typing/ctype.cmx typing/includeclass.cmi
-typing/includecore.cmo: typing/types.cmi typing/typedtree.cmi \
-    typing/predef.cmi typing/path.cmi utils/misc.cmi typing/ctype.cmi \
-    typing/btype.cmi parsing/asttypes.cmi typing/includecore.cmi
-typing/includecore.cmx: typing/types.cmx typing/typedtree.cmx \
-    typing/predef.cmx typing/path.cmx utils/misc.cmx typing/ctype.cmx \
-    typing/btype.cmx parsing/asttypes.cmi typing/includecore.cmi
-typing/includemod.cmo: typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
+typing/includecore.cmo : typing/types.cmi typing/typedtree.cmi \
+    typing/predef.cmi typing/path.cmi utils/misc.cmi typing/ident.cmi \
+    typing/env.cmi typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \
+    typing/includecore.cmi
+typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \
+    typing/predef.cmx typing/path.cmx utils/misc.cmx typing/ident.cmx \
+    typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \
+    typing/includecore.cmi
+typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
     typing/subst.cmi typing/printtyp.cmi typing/path.cmi typing/mtype.cmi \
-    utils/misc.cmi typing/includecore.cmi typing/includeclass.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/includemod.cmi
-typing/includemod.cmx: typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
+    utils/misc.cmi parsing/location.cmi typing/includecore.cmi \
+    typing/includeclass.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+    utils/clflags.cmi typing/includemod.cmi
+typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
     typing/subst.cmx typing/printtyp.cmx typing/path.cmx typing/mtype.cmx \
-    utils/misc.cmx typing/includecore.cmx typing/includeclass.cmx \
-    typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/includemod.cmi
-typing/mtype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \
+    utils/misc.cmx parsing/location.cmx typing/includecore.cmx \
+    typing/includeclass.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+    utils/clflags.cmx typing/includemod.cmi
+typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
     typing/btype.cmi parsing/asttypes.cmi typing/mtype.cmi
-typing/mtype.cmx: typing/types.cmx typing/subst.cmx typing/path.cmx \
+typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \
     typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi typing/mtype.cmi
-typing/oprint.cmo: typing/outcometree.cmi parsing/asttypes.cmi \
+typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \
     typing/oprint.cmi
-typing/oprint.cmx: typing/outcometree.cmi parsing/asttypes.cmi \
+typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \
     typing/oprint.cmi
-typing/parmatch.cmo: utils/warnings.cmi typing/types.cmi typing/typedtree.cmi \
-    typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
+typing/parmatch.cmo : utils/warnings.cmi typing/types.cmi \
+    typing/typedtree.cmi typing/subst.cmi typing/predef.cmi typing/path.cmi \
+    parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \
     typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \
     typing/parmatch.cmi
-typing/parmatch.cmx: utils/warnings.cmx typing/types.cmx typing/typedtree.cmx \
-    typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
+typing/parmatch.cmx : utils/warnings.cmx typing/types.cmx \
+    typing/typedtree.cmx typing/subst.cmx typing/predef.cmx typing/path.cmx \
+    parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \
     typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \
     typing/parmatch.cmi
-typing/path.cmo: typing/ident.cmi typing/path.cmi
-typing/path.cmx: typing/ident.cmx typing/path.cmi
-typing/predef.cmo: typing/types.cmi typing/path.cmi typing/ident.cmi \
-    typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi
-typing/predef.cmx: typing/types.cmx typing/path.cmx typing/ident.cmx \
-    typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi
-typing/primitive.cmo: utils/misc.cmi typing/primitive.cmi
-typing/primitive.cmx: utils/misc.cmx typing/primitive.cmi
-typing/printtyp.cmo: typing/types.cmi typing/primitive.cmi typing/predef.cmi \
-    typing/path.cmi typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \
-    parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
-    typing/printtyp.cmi
-typing/printtyp.cmx: typing/types.cmx typing/primitive.cmx typing/predef.cmx \
-    typing/path.cmx typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \
-    parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
-    typing/printtyp.cmi
-typing/stypes.cmo: typing/typedtree.cmi typing/printtyp.cmi \
+typing/path.cmo : typing/ident.cmi typing/path.cmi
+typing/path.cmx : typing/ident.cmx typing/path.cmi
+typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \
+    typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi
+typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \
+    typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi
+typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi
+typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi
+typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
+    typing/predef.cmi typing/path.cmi typing/outcometree.cmi \
+    typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \
+    typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \
+    parsing/asttypes.cmi typing/printtyp.cmi
+typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \
+    typing/predef.cmx typing/path.cmx typing/outcometree.cmi \
+    typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \
+    typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
+    parsing/asttypes.cmi typing/printtyp.cmi
+typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi \
     parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
-typing/stypes.cmx: typing/typedtree.cmx typing/printtyp.cmx \
+typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \
     parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi
-typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \
-    utils/misc.cmi typing/ident.cmi typing/btype.cmi typing/subst.cmi
-typing/subst.cmx: typing/types.cmx utils/tbl.cmx typing/path.cmx \
-    utils/misc.cmx typing/ident.cmx typing/btype.cmx typing/subst.cmi
-typing/typeclass.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
-    typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
-    typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi \
-    typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \
+typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \
+    utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/btype.cmi \
+    typing/subst.cmi
+typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \
+    utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/btype.cmx \
+    typing/subst.cmi
+typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \
+    typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
+    typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \
+    typing/printtyp.cmi typing/predef.cmi typing/path.cmi \
+    parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
     typing/btype.cmi parsing/asttypes.cmi typing/typeclass.cmi
-typing/typeclass.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
-    typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \
-    typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx typing/predef.cmx \
-    typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \
+typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \
+    typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
+    typing/typecore.cmx typing/subst.cmx typing/stypes.cmx \
+    typing/printtyp.cmx typing/predef.cmx typing/path.cmx \
+    parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx typing/includeclass.cmx \
     typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi typing/typeclass.cmi
-typing/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
-    typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \
+typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \
+    typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \
     typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
     typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \
     typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
     utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
     typing/typecore.cmi
-typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
-    typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \
+typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \
+    typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \
     typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
     typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \
     typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
     utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
     typing/typecore.cmi
-typing/typedecl.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
-    typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \
-    typing/primitive.cmi typing/predef.cmi typing/path.cmi \
-    parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
-    parsing/location.cmi typing/includecore.cmi typing/ident.cmi \
-    typing/env.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmi \
-    typing/btype.cmi parsing/asttypes.cmi typing/typedecl.cmi
-typing/typedecl.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
-    typing/typedtree.cmx typing/subst.cmx typing/printtyp.cmx \
-    typing/primitive.cmx typing/predef.cmx typing/path.cmx \
-    parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
-    parsing/location.cmx typing/includecore.cmx typing/ident.cmx \
-    typing/env.cmx typing/ctype.cmx utils/config.cmx utils/clflags.cmx \
-    typing/btype.cmx parsing/asttypes.cmi typing/typedecl.cmi
-typing/typedtree.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \
+typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \
+    typing/types.cmi typing/typedtree.cmi typing/subst.cmi \
+    typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
+    typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \
+    typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
+    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+    typing/typedecl.cmi
+typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \
+    typing/types.cmx typing/typedtree.cmx typing/subst.cmx \
+    typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
+    typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \
+    parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \
+    typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
+    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+    typing/typedecl.cmi
+typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
     utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
     parsing/asttypes.cmi typing/typedtree.cmi
-typing/typedtree.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \
+typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
     utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
     parsing/asttypes.cmi typing/typedtree.cmi
-typing/typemod.cmo: typing/typetexp.cmi typing/types.cmi typing/typedtree.cmi \
-    typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
-    typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/path.cmi \
-    parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \
-    parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
-    utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
-    typing/typemod.cmi
-typing/typemod.cmx: typing/typetexp.cmx typing/types.cmx typing/typedtree.cmx \
-    typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \
-    typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx typing/path.cmx \
-    parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \
-    parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \
-    typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
-    utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
-    typing/typemod.cmi
-typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \
-    typing/ident.cmi parsing/asttypes.cmi typing/types.cmi
-typing/types.cmx: typing/primitive.cmx typing/path.cmx utils/misc.cmx \
-    typing/ident.cmx parsing/asttypes.cmi typing/types.cmi
-typing/typetexp.cmo: utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
+typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
+    typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
+    typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \
+    typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi \
+    typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
+    parsing/location.cmi typing/includemod.cmi typing/ident.cmi \
+    typing/env.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmi \
+    typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi typing/typemod.cmi
+typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
+    typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \
+    typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \
+    typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi \
+    typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
+    parsing/location.cmx typing/includemod.cmx typing/ident.cmx \
+    typing/env.cmx typing/ctype.cmx utils/config.cmx utils/clflags.cmx \
+    typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi typing/typemod.cmi
+typing/types.cmo : typing/primitive.cmi typing/path.cmi utils/misc.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
+    parsing/asttypes.cmi typing/types.cmi
+typing/types.cmx : typing/primitive.cmx typing/path.cmx utils/misc.cmx \
+    parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
+    parsing/asttypes.cmi typing/types.cmi
+typing/typetexp.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
     typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/env.cmi \
     typing/ctype.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
     typing/typetexp.cmi
-typing/typetexp.cmx: utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
+typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \
     typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \
     parsing/longident.cmx parsing/location.cmx typing/env.cmx \
     typing/ctype.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
     typing/typetexp.cmi
-typing/unused_var.cmo: utils/warnings.cmi parsing/parsetree.cmi \
-    parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \
-    typing/unused_var.cmi
-typing/unused_var.cmx: utils/warnings.cmx parsing/parsetree.cmi \
-    parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \
-    typing/unused_var.cmi
-bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi
-bytecomp/bytelibrarian.cmi:
-bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/cmo_format.cmi
-bytecomp/bytepackager.cmi: typing/ident.cmi
-bytecomp/bytesections.cmi:
-bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi
-bytecomp/dll.cmi:
-bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi
-bytecomp/instruct.cmi: typing/types.cmi typing/subst.cmi parsing/location.cmi \
-    bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
-bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \
+bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi
+bytecomp/bytelibrarian.cmi :
+bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi
+bytecomp/bytepackager.cmi : typing/ident.cmi
+bytecomp/bytesections.cmi :
+bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi
+bytecomp/dll.cmi :
+bytecomp/emitcode.cmi : bytecomp/instruct.cmi bytecomp/cmo_format.cmi
+bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \
+    parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
+bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
     parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
-bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \
+bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
-bytecomp/meta.cmi:
-bytecomp/printinstr.cmi: bytecomp/instruct.cmi
-bytecomp/printlambda.cmi: bytecomp/lambda.cmi
-bytecomp/runtimedef.cmi:
-bytecomp/simplif.cmi: bytecomp/lambda.cmi
-bytecomp/switch.cmi:
-bytecomp/symtable.cmi: typing/ident.cmi bytecomp/cmo_format.cmi
-bytecomp/translclass.cmi: typing/typedtree.cmi parsing/location.cmi \
+bytecomp/meta.cmi :
+bytecomp/printinstr.cmi : bytecomp/instruct.cmi
+bytecomp/printlambda.cmi : bytecomp/lambda.cmi
+bytecomp/runtimedef.cmi :
+bytecomp/simplif.cmi : bytecomp/lambda.cmi
+bytecomp/switch.cmi :
+bytecomp/symtable.cmi : typing/ident.cmi bytecomp/cmo_format.cmi
+bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
-bytecomp/translcore.cmi: typing/types.cmi typing/typedtree.cmi \
+bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \
     typing/primitive.cmi typing/path.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi
-bytecomp/translmod.cmi: typing/typedtree.cmi typing/primitive.cmi \
+bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi
-bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
-bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \
+bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
+bytecomp/typeopt.cmi : typing/typedtree.cmi typing/path.cmi \
     bytecomp/lambda.cmi
-bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \
+bytecomp/bytegen.cmo : typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \
     typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
     bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \
     parsing/asttypes.cmi bytecomp/bytegen.cmi
-bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
+bytecomp/bytegen.cmx : typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
     typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
     bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \
     parsing/asttypes.cmi bytecomp/bytegen.cmi
-bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \
-    bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
-    bytecomp/bytelibrarian.cmi
-bytecomp/bytelibrarian.cmx: utils/misc.cmx utils/config.cmx \
-    bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \
-    bytecomp/bytelibrarian.cmi
-bytecomp/bytelink.cmo: bytecomp/symtable.cmi bytecomp/opcodes.cmo \
-    utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi bytecomp/dll.cmi \
+bytecomp/bytelibrarian.cmo : utils/misc.cmi parsing/location.cmi \
+    utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \
+    bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi
+bytecomp/bytelibrarian.cmx : utils/misc.cmx parsing/location.cmx \
+    utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \
+    bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi
+bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \
+    bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \
+    bytecomp/instruct.cmi typing/ident.cmi bytecomp/dll.cmi \
     utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \
     utils/clflags.cmi utils/ccomp.cmi bytecomp/bytesections.cmi \
     bytecomp/bytelink.cmi
-bytecomp/bytelink.cmx: bytecomp/symtable.cmx bytecomp/opcodes.cmx \
-    utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \
+bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \
+    bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \
+    bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \
     utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \
     utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \
     bytecomp/bytelink.cmi
-bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \
-    typing/subst.cmi typing/path.cmi utils/misc.cmi bytecomp/instruct.cmi \
-    typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \
-    bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
-    bytecomp/bytegen.cmi bytecomp/bytepackager.cmi
-bytecomp/bytepackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \
-    typing/subst.cmx typing/path.cmx utils/misc.cmx bytecomp/instruct.cmx \
-    typing/ident.cmx typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \
-    bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \
-    bytecomp/bytegen.cmx bytecomp/bytepackager.cmi
-bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi
-bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi
-bytecomp/dll.cmo: utils/misc.cmi utils/config.cmi bytecomp/dll.cmi
-bytecomp/dll.cmx: utils/misc.cmx utils/config.cmx bytecomp/dll.cmi
-bytecomp/emitcode.cmo: bytecomp/translmod.cmi typing/primitive.cmi \
+bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
+    typing/subst.cmi typing/path.cmi utils/misc.cmi parsing/location.cmi \
+    bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \
+    bytecomp/emitcode.cmi utils/config.cmi bytecomp/cmo_format.cmi \
+    utils/clflags.cmi bytecomp/bytelink.cmi bytecomp/bytegen.cmi \
+    bytecomp/bytepackager.cmi
+bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
+    typing/subst.cmx typing/path.cmx utils/misc.cmx parsing/location.cmx \
+    bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \
+    bytecomp/emitcode.cmx utils/config.cmx bytecomp/cmo_format.cmi \
+    utils/clflags.cmx bytecomp/bytelink.cmx bytecomp/bytegen.cmx \
+    bytecomp/bytepackager.cmi
+bytecomp/bytesections.cmo : utils/misc.cmi utils/config.cmi \
+    bytecomp/bytesections.cmi
+bytecomp/bytesections.cmx : utils/misc.cmx utils/config.cmx \
+    bytecomp/bytesections.cmi
+bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi
+bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi
+bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \
     bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \
     bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \
     bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \
     parsing/asttypes.cmi bytecomp/emitcode.cmi
-bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \
+bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \
     bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \
     bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \
     bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \
     parsing/asttypes.cmi bytecomp/emitcode.cmi
-bytecomp/instruct.cmo: typing/types.cmi typing/subst.cmi parsing/location.cmi \
-    bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/instruct.cmi
-bytecomp/instruct.cmx: typing/types.cmx typing/subst.cmx parsing/location.cmx \
-    bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx bytecomp/instruct.cmi
-bytecomp/lambda.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \
+bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \
+    parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
+    bytecomp/instruct.cmi
+bytecomp/instruct.cmx : typing/types.cmx typing/subst.cmx \
+    parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
+    bytecomp/instruct.cmi
+bytecomp/lambda.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \
     utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \
     parsing/asttypes.cmi bytecomp/lambda.cmi
-bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \
+bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
     utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \
     parsing/asttypes.cmi bytecomp/lambda.cmi
-bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \
+bytecomp/matching.cmo : typing/types.cmi bytecomp/typeopt.cmi \
     typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi \
     typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
     utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
     bytecomp/matching.cmi
-bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \
+bytecomp/matching.cmx : typing/types.cmx bytecomp/typeopt.cmx \
     typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \
     typing/primitive.cmx typing/predef.cmx typing/path.cmx \
     typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
     utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
     bytecomp/matching.cmi
-bytecomp/meta.cmo: bytecomp/meta.cmi
-bytecomp/meta.cmx: bytecomp/meta.cmi
-bytecomp/opcodes.cmo:
-bytecomp/opcodes.cmx:
-bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \
+bytecomp/meta.cmo : bytecomp/meta.cmi
+bytecomp/meta.cmx : bytecomp/meta.cmi
+bytecomp/opcodes.cmo :
+bytecomp/opcodes.cmx :
+bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \
     bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \
     bytecomp/printinstr.cmi
-bytecomp/printinstr.cmx: bytecomp/printlambda.cmx parsing/location.cmx \
+bytecomp/printinstr.cmx : bytecomp/printlambda.cmx parsing/location.cmx \
     bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \
     bytecomp/printinstr.cmi
-bytecomp/printlambda.cmo: typing/types.cmi typing/primitive.cmi \
+bytecomp/printlambda.cmo : typing/types.cmi typing/primitive.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
     parsing/asttypes.cmi bytecomp/printlambda.cmi
-bytecomp/printlambda.cmx: typing/types.cmx typing/primitive.cmx \
+bytecomp/printlambda.cmx : typing/types.cmx typing/primitive.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
     parsing/asttypes.cmi bytecomp/printlambda.cmi
-bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi
-bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi
-bytecomp/simplif.cmo: typing/stypes.cmi bytecomp/lambda.cmi typing/ident.cmi \
-    utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \
+bytecomp/runtimedef.cmo : bytecomp/runtimedef.cmi
+bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi
+bytecomp/simplif.cmo : utils/tbl.cmi typing/stypes.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \
     bytecomp/simplif.cmi
-bytecomp/simplif.cmx: typing/stypes.cmx bytecomp/lambda.cmx typing/ident.cmx \
-    utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \
+bytecomp/simplif.cmx : utils/tbl.cmx typing/stypes.cmx bytecomp/lambda.cmx \
+    typing/ident.cmx utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \
     bytecomp/simplif.cmi
-bytecomp/switch.cmo: bytecomp/switch.cmi
-bytecomp/switch.cmx: bytecomp/switch.cmi
-bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \
+bytecomp/switch.cmo : bytecomp/switch.cmi
+bytecomp/switch.cmx : bytecomp/switch.cmi
+bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \
     typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \
     typing/ident.cmi bytecomp/dll.cmi bytecomp/cmo_format.cmi \
     utils/clflags.cmi bytecomp/bytesections.cmi parsing/asttypes.cmi \
     bytecomp/symtable.cmi
-bytecomp/symtable.cmx: utils/tbl.cmx bytecomp/runtimedef.cmx \
+bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \
     typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \
     typing/ident.cmx bytecomp/dll.cmx bytecomp/cmo_format.cmi \
     utils/clflags.cmx bytecomp/bytesections.cmx parsing/asttypes.cmi \
     bytecomp/symtable.cmi
-bytecomp/translclass.cmo: typing/types.cmi bytecomp/typeopt.cmi \
+bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \
     typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \
     typing/path.cmi utils/misc.cmi bytecomp/matching.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \
     typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi
-bytecomp/translclass.cmx: typing/types.cmx bytecomp/typeopt.cmx \
+bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \
     typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \
     typing/path.cmx utils/misc.cmx bytecomp/matching.cmx parsing/location.cmx \
     bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi
-bytecomp/translcore.cmo: typing/types.cmi bytecomp/typeopt.cmi \
+bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \
     typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \
     typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \
     bytecomp/matching.cmi parsing/location.cmi bytecomp/lambda.cmi \
     typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \
     typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi
-bytecomp/translcore.cmx: typing/types.cmx bytecomp/typeopt.cmx \
+bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \
     typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \
     typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \
     bytecomp/matching.cmx parsing/location.cmx bytecomp/lambda.cmx \
     typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi
-bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \
+bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \
     bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
     typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
     typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
     typing/ctype.cmi parsing/asttypes.cmi bytecomp/translmod.cmi
-bytecomp/translmod.cmx: typing/types.cmx typing/typedtree.cmx \
+bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \
     bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
     typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
     typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
     typing/ctype.cmx parsing/asttypes.cmi bytecomp/translmod.cmi
-bytecomp/translobj.cmo: typing/primitive.cmi utils/misc.cmi \
+bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \
     parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
     utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
     bytecomp/translobj.cmi
-bytecomp/translobj.cmx: typing/primitive.cmx utils/misc.cmx \
+bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \
     parsing/longident.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
     utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
     bytecomp/translobj.cmi
-bytecomp/typeopt.cmo: typing/types.cmi typing/typedtree.cmi \
+bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
     bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
     parsing/asttypes.cmi bytecomp/typeopt.cmi
-bytecomp/typeopt.cmx: typing/types.cmx typing/typedtree.cmx \
+bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \
     typing/primitive.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
     bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
     parsing/asttypes.cmi bytecomp/typeopt.cmi
-asmcomp/asmgen.cmi: bytecomp/lambda.cmi asmcomp/cmm.cmi
-asmcomp/asmlibrarian.cmi:
-asmcomp/asmlink.cmi: asmcomp/cmx_format.cmi
-asmcomp/asmpackager.cmi:
-asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \
+asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi
+asmcomp/asmlibrarian.cmi :
+asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi
+asmcomp/asmpackager.cmi :
+asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \
     asmcomp/debuginfo.cmi parsing/asttypes.cmi
-asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi
-asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi
-asmcomp/cmmgen.cmi: asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
-    asmcomp/clambda.cmi
-asmcomp/cmx_format.cmi: asmcomp/clambda.cmi
-asmcomp/codegen.cmi: asmcomp/cmm.cmi
-asmcomp/coloring.cmi:
-asmcomp/comballoc.cmi: asmcomp/mach.cmi
-asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/cmx_format.cmi \
+asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi
+asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi
+asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
     asmcomp/clambda.cmi
-asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi
-asmcomp/emit.cmi: asmcomp/linearize.cmi asmcomp/cmm.cmi
-asmcomp/emitaux.cmi: asmcomp/debuginfo.cmi
-asmcomp/interf.cmi: asmcomp/mach.cmi
-asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi
-asmcomp/liveness.cmi: asmcomp/mach.cmi
-asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
+asmcomp/cmx_format.cmi : asmcomp/clambda.cmi
+asmcomp/codegen.cmi : asmcomp/cmm.cmi
+asmcomp/coloring.cmi :
+asmcomp/comballoc.cmi : asmcomp/mach.cmi
+asmcomp/compilenv.cmi : bytecomp/lambda.cmi typing/ident.cmi \
+    asmcomp/cmx_format.cmi asmcomp/clambda.cmi
+asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi
+asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi
+asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi
+asmcomp/interf.cmi : asmcomp/mach.cmi
+asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \
+    asmcomp/debuginfo.cmi
+asmcomp/liveness.cmi : asmcomp/mach.cmi
+asmcomp/mach.cmi : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
     asmcomp/arch.cmo
-asmcomp/printcmm.cmi: asmcomp/cmm.cmi
-asmcomp/printlinear.cmi: asmcomp/linearize.cmi
-asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
-asmcomp/proc.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
-asmcomp/reg.cmi: asmcomp/cmm.cmi
-asmcomp/reload.cmi: asmcomp/mach.cmi
-asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi
-asmcomp/schedgen.cmi: asmcomp/mach.cmi asmcomp/linearize.cmi
-asmcomp/scheduling.cmi: asmcomp/linearize.cmi
-asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
+asmcomp/printclambda.cmi : asmcomp/clambda.cmi
+asmcomp/printcmm.cmi : asmcomp/cmm.cmi
+asmcomp/printlinear.cmi : asmcomp/linearize.cmi
+asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
+asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
+asmcomp/reg.cmi : asmcomp/cmm.cmi
+asmcomp/reload.cmi : asmcomp/mach.cmi
+asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi
+asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi
+asmcomp/scheduling.cmi : asmcomp/linearize.cmi
+asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
     typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo
-asmcomp/selection.cmi: asmcomp/mach.cmi asmcomp/cmm.cmi
-asmcomp/spill.cmi: asmcomp/mach.cmi
-asmcomp/split.cmi: asmcomp/mach.cmi
-asmcomp/arch.cmo:
-asmcomp/arch.cmx:
-asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \
+asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi
+asmcomp/spill.cmi : asmcomp/mach.cmi
+asmcomp/split.cmi : asmcomp/mach.cmi
+asmcomp/arch.cmo :
+asmcomp/arch.cmx :
+asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \
     asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \
     asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
     asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \
-    utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi \
+    utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi asmcomp/liveness.cmi \
     asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \
     asmcomp/emit.cmi utils/config.cmi asmcomp/compilenv.cmi \
     asmcomp/comballoc.cmi asmcomp/coloring.cmi asmcomp/cmmgen.cmi \
     asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi
-asmcomp/asmgen.cmx: bytecomp/translmod.cmx asmcomp/split.cmx \
+asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \
     asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \
     asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \
     asmcomp/printlinear.cmx asmcomp/printcmm.cmx typing/primitive.cmx \
-    utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx \
+    utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx asmcomp/liveness.cmx \
     asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \
     asmcomp/emit.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/comballoc.cmx asmcomp/coloring.cmx asmcomp/cmmgen.cmx \
     asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi
-asmcomp/asmlibrarian.cmo: utils/misc.cmi utils/config.cmi \
+asmcomp/asmlibrarian.cmo : utils/misc.cmi utils/config.cmi \
     asmcomp/compilenv.cmi asmcomp/cmx_format.cmi utils/clflags.cmi \
     asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \
     asmcomp/asmlibrarian.cmi
-asmcomp/asmlibrarian.cmx: utils/misc.cmx utils/config.cmx \
+asmcomp/asmlibrarian.cmx : utils/misc.cmx utils/config.cmx \
     asmcomp/compilenv.cmx asmcomp/cmx_format.cmi utils/clflags.cmx \
     asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \
     asmcomp/asmlibrarian.cmi
-asmcomp/asmlink.cmo: bytecomp/runtimedef.cmi asmcomp/proc.cmi utils/misc.cmi \
-    parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \
+asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi asmcomp/proc.cmi \
+    utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \
     utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \
     asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi utils/clflags.cmi \
     utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi
-asmcomp/asmlink.cmx: bytecomp/runtimedef.cmx asmcomp/proc.cmx utils/misc.cmx \
-    parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \
+asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx asmcomp/proc.cmx \
+    utils/misc.cmx parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \
     utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \
     utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi
-asmcomp/asmpackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \
+asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \
     utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \
     typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi \
     asmcomp/cmx_format.cmi utils/clflags.cmi asmcomp/clambda.cmi \
     utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \
     asmcomp/asmpackager.cmi
-asmcomp/asmpackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \
+asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \
     utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \
     typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \
     utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \
     asmcomp/asmpackager.cmi
-asmcomp/clambda.cmo: bytecomp/lambda.cmi typing/ident.cmi \
+asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \
     asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi
-asmcomp/clambda.cmx: bytecomp/lambda.cmx typing/ident.cmx \
+asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \
     asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi
-asmcomp/closure.cmo: utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \
+asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \
     utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
     asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \
     parsing/asttypes.cmi asmcomp/closure.cmi
-asmcomp/closure.cmx: utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \
+asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \
     utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
     asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \
     parsing/asttypes.cmi asmcomp/closure.cmi
-asmcomp/cmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \
+asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \
     asmcomp/cmm.cmi
-asmcomp/cmm.cmx: typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \
+asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \
     asmcomp/cmm.cmi
-asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
+asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \
     typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \
     asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
     asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \
     asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
     asmcomp/cmmgen.cmi
-asmcomp/cmmgen.cmx: typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \
+asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \
     typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \
     asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
     asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
     asmcomp/cmmgen.cmi
-asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
+asmcomp/codegen.cmo : asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \
     asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \
     asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \
     asmcomp/interf.cmi asmcomp/emit.cmi asmcomp/coloring.cmi asmcomp/cmm.cmi \
     asmcomp/codegen.cmi
-asmcomp/codegen.cmx: asmcomp/split.cmx asmcomp/spill.cmx asmcomp/reload.cmx \
+asmcomp/codegen.cmx : asmcomp/split.cmx asmcomp/spill.cmx asmcomp/reload.cmx \
     asmcomp/reg.cmx asmcomp/printmach.cmx asmcomp/printlinear.cmx \
     asmcomp/printcmm.cmx asmcomp/liveness.cmx asmcomp/linearize.cmx \
     asmcomp/interf.cmx asmcomp/emit.cmx asmcomp/coloring.cmx asmcomp/cmm.cmx \
     asmcomp/codegen.cmi
-asmcomp/coloring.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi
-asmcomp/coloring.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi
-asmcomp/comballoc.cmo: asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \
+asmcomp/coloring.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi
+asmcomp/coloring.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi
+asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \
     asmcomp/arch.cmo asmcomp/comballoc.cmi
-asmcomp/comballoc.cmx: asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \
+asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \
     asmcomp/arch.cmx asmcomp/comballoc.cmi
-asmcomp/compilenv.cmo: utils/misc.cmi typing/ident.cmi typing/env.cmi \
-    utils/config.cmi asmcomp/cmx_format.cmi asmcomp/clambda.cmi \
-    asmcomp/compilenv.cmi
-asmcomp/compilenv.cmx: utils/misc.cmx typing/ident.cmx typing/env.cmx \
-    utils/config.cmx asmcomp/cmx_format.cmi asmcomp/clambda.cmx \
-    asmcomp/compilenv.cmi
-asmcomp/debuginfo.cmo: parsing/location.cmi bytecomp/lambda.cmi \
+asmcomp/compilenv.cmo : utils/misc.cmi parsing/location.cmi \
+    bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
+    asmcomp/cmx_format.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi
+asmcomp/compilenv.cmx : utils/misc.cmx parsing/location.cmx \
+    bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
+    asmcomp/cmx_format.cmi asmcomp/clambda.cmx asmcomp/compilenv.cmi
+asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \
     asmcomp/debuginfo.cmi
-asmcomp/debuginfo.cmx: parsing/location.cmx bytecomp/lambda.cmx \
+asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \
     asmcomp/debuginfo.cmi
-asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
+asmcomp/emit.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \
     asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
     asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emit.cmi
-asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
+asmcomp/emit.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
     asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \
     asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
     asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi
-asmcomp/emitaux.cmo: asmcomp/reg.cmi asmcomp/linearize.cmi \
-    asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
-    asmcomp/emitaux.cmi
-asmcomp/emitaux.cmx: asmcomp/reg.cmx asmcomp/linearize.cmx \
-    asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
-    asmcomp/emitaux.cmi
-asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
+asmcomp/emitaux.cmo : asmcomp/reg.cmi asmcomp/linearize.cmi \
+    asmcomp/debuginfo.cmi utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi \
+    asmcomp/arch.cmo asmcomp/emitaux.cmi
+asmcomp/emitaux.cmx : asmcomp/reg.cmx asmcomp/linearize.cmx \
+    asmcomp/debuginfo.cmx utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx \
+    asmcomp/arch.cmx asmcomp/emitaux.cmi
+asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi asmcomp/interf.cmi
-asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
+asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
     asmcomp/mach.cmx asmcomp/interf.cmi
-asmcomp/linearize.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
+asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
     asmcomp/linearize.cmi
-asmcomp/linearize.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
+asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
     asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
     asmcomp/linearize.cmi
-asmcomp/liveness.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \
-    utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi
-asmcomp/liveness.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \
-    utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmi
-asmcomp/mach.cmo: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
+asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
+    asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \
+    asmcomp/liveness.cmi
+asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
+    asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx \
+    asmcomp/liveness.cmi
+asmcomp/mach.cmo : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
     asmcomp/arch.cmo asmcomp/mach.cmi
-asmcomp/mach.cmx: asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
+asmcomp/mach.cmx : asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
     asmcomp/arch.cmx asmcomp/mach.cmi
-asmcomp/printcmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
-    asmcomp/printcmm.cmi
-asmcomp/printcmm.cmx: typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
-    asmcomp/printcmm.cmi
-asmcomp/printlinear.cmo: asmcomp/printmach.cmi asmcomp/mach.cmi \
+asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \
+    typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/clambda.cmi \
+    parsing/asttypes.cmi asmcomp/printclambda.cmi
+asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \
+    typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/clambda.cmx \
+    parsing/asttypes.cmi asmcomp/printclambda.cmi
+asmcomp/printcmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi \
+    asmcomp/cmm.cmi asmcomp/printcmm.cmi
+asmcomp/printcmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx \
+    asmcomp/cmm.cmx asmcomp/printcmm.cmi
+asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/mach.cmi \
     asmcomp/linearize.cmi asmcomp/debuginfo.cmi asmcomp/printlinear.cmi
-asmcomp/printlinear.cmx: asmcomp/printmach.cmx asmcomp/mach.cmx \
+asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/mach.cmx \
     asmcomp/linearize.cmx asmcomp/debuginfo.cmx asmcomp/printlinear.cmi
-asmcomp/printmach.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printcmm.cmi \
-    asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
-    asmcomp/printmach.cmi
-asmcomp/printmach.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx \
-    asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
-    asmcomp/printmach.cmi
-asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
-    utils/config.cmi asmcomp/cmm.cmi utils/ccomp.cmi asmcomp/arch.cmo \
-    asmcomp/proc.cmi
-asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
-    utils/config.cmx asmcomp/cmm.cmx utils/ccomp.cmx asmcomp/arch.cmx \
-    asmcomp/proc.cmi
-asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
-asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
-asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
+asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \
+    asmcomp/printcmm.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi \
+    asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi
+asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \
+    asmcomp/printcmm.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx \
+    asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi
+asmcomp/proc.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
+    utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \
+    asmcomp/arch.cmo asmcomp/proc.cmi
+asmcomp/proc.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
+    utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \
+    asmcomp/arch.cmx asmcomp/proc.cmi
+asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/reg.cmi
+asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/reg.cmi
+asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
     asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi
-asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
+asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
     asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi
-asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
+asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/reloadgen.cmi
-asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
+asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/reloadgen.cmi
-asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
+asmcomp/schedgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
     asmcomp/schedgen.cmi
-asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
+asmcomp/schedgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
     asmcomp/schedgen.cmi
-asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi
-asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi
-asmcomp/selectgen.cmo: utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \
+asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi
+asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi
+asmcomp/selectgen.cmo : utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \
     asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \
     asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
     asmcomp/selectgen.cmi
-asmcomp/selectgen.cmx: utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \
+asmcomp/selectgen.cmx : utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \
     asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \
     asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
     asmcomp/selectgen.cmi
-asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
-    utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
+asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/reg.cmi \
+    asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi \
     utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi
-asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
-    utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
+asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/reg.cmx \
+    asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx \
     utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi
-asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
+asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
     asmcomp/mach.cmi asmcomp/spill.cmi
-asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
+asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
     asmcomp/mach.cmx asmcomp/spill.cmi
-asmcomp/split.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
+asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
     asmcomp/split.cmi
-asmcomp/split.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
+asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
     asmcomp/split.cmi
-driver/compile.cmi: typing/env.cmi
-driver/errors.cmi:
-driver/main.cmi:
-driver/main_args.cmi:
-driver/optcompile.cmi: typing/env.cmi
-driver/opterrors.cmi:
-driver/optmain.cmi:
-driver/pparse.cmi:
-driver/compile.cmo: utils/warnings.cmi typing/unused_var.cmi \
-    typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \
-    typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
-    bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \
-    driver/pparse.cmi parsing/parse.cmi utils/misc.cmi parsing/location.cmi \
-    typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \
-    utils/clflags.cmi utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi
-driver/compile.cmx: utils/warnings.cmx typing/unused_var.cmx \
-    typing/typemod.cmx typing/typedtree.cmx bytecomp/translmod.cmx \
-    typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
-    bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \
-    driver/pparse.cmx parsing/parse.cmx utils/misc.cmx parsing/location.cmx \
-    typing/ident.cmx typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \
-    utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi
-driver/errors.cmo: utils/warnings.cmi typing/typetexp.cmi typing/typemod.cmi \
-    typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
-    bytecomp/translmod.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \
-    parsing/syntaxerr.cmi bytecomp/symtable.cmi driver/pparse.cmi \
-    parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \
-    typing/env.cmi typing/ctype.cmi bytecomp/bytepackager.cmi \
-    bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/errors.cmi
-driver/errors.cmx: utils/warnings.cmx typing/typetexp.cmx typing/typemod.cmx \
-    typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \
-    bytecomp/translmod.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \
-    parsing/syntaxerr.cmx bytecomp/symtable.cmx driver/pparse.cmx \
-    parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \
-    typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \
-    bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi
-driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
-    driver/errors.cmi utils/config.cmi driver/compile.cmi utils/clflags.cmi \
-    bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
-    bytecomp/bytelibrarian.cmi driver/main.cmi
-driver/main.cmx: utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \
-    driver/errors.cmx utils/config.cmx driver/compile.cmx utils/clflags.cmx \
-    bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
-    bytecomp/bytelibrarian.cmx driver/main.cmi
-driver/main_args.cmo: utils/warnings.cmi driver/main_args.cmi
-driver/main_args.cmx: utils/warnings.cmx driver/main_args.cmi
-driver/optcompile.cmo: utils/warnings.cmi typing/unused_var.cmi \
-    typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \
-    typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
-    bytecomp/printlambda.cmi parsing/printast.cmi driver/pparse.cmi \
+driver/compile.cmi : typing/env.cmi
+driver/errors.cmi :
+driver/main.cmi :
+driver/main_args.cmi :
+driver/optcompile.cmi : typing/env.cmi
+driver/opterrors.cmi :
+driver/optmain.cmi :
+driver/pparse.cmi :
+driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \
+    typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \
+    bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
+    bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \
     parsing/parse.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \
-    typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi utils/clflags.cmi \
-    utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi
-driver/optcompile.cmx: utils/warnings.cmx typing/unused_var.cmx \
-    typing/typemod.cmx typing/typedtree.cmx bytecomp/translmod.cmx \
-    typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
-    bytecomp/printlambda.cmx parsing/printast.cmx driver/pparse.cmx \
+    typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi \
+    utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi
+driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \
+    typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \
+    bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
+    bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \
     parsing/parse.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \
-    typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx utils/clflags.cmx \
-    utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi
-driver/opterrors.cmo: utils/warnings.cmi typing/typetexp.cmi \
+    typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \
+    utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi
+driver/errors.cmo : utils/warnings.cmi typing/typetexp.cmi \
+    typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \
+    typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \
+    bytecomp/translclass.cmi parsing/syntaxerr.cmi bytecomp/symtable.cmi \
+    driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \
+    typing/includemod.cmi typing/env.cmi typing/ctype.cmi \
+    bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \
+    bytecomp/bytelibrarian.cmi driver/errors.cmi
+driver/errors.cmx : utils/warnings.cmx typing/typetexp.cmx \
+    typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \
+    typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \
+    bytecomp/translclass.cmx parsing/syntaxerr.cmx bytecomp/symtable.cmx \
+    driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \
+    typing/includemod.cmx typing/env.cmx typing/ctype.cmx \
+    bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \
+    bytecomp/bytelibrarian.cmx driver/errors.cmi
+driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \
+    parsing/location.cmi driver/errors.cmi utils/config.cmi \
+    driver/compile.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \
+    bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi
+driver/main.cmx : utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \
+    parsing/location.cmx driver/errors.cmx utils/config.cmx \
+    driver/compile.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \
+    bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi
+driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi
+driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi
+driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \
+    typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \
+    bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
+    parsing/printast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \
+    parsing/location.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \
+    asmcomp/compilenv.cmi utils/clflags.cmi utils/ccomp.cmi \
+    asmcomp/asmgen.cmi driver/optcompile.cmi
+driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \
+    typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \
+    bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
+    parsing/printast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \
+    parsing/location.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \
+    asmcomp/compilenv.cmx utils/clflags.cmx utils/ccomp.cmx \
+    asmcomp/asmgen.cmx driver/optcompile.cmi
+driver/opterrors.cmo : utils/warnings.cmi typing/typetexp.cmi \
     typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \
     typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \
     bytecomp/translclass.cmi parsing/syntaxerr.cmi driver/pparse.cmi \
@@ -776,7 +808,7 @@ driver/opterrors.cmo: utils/warnings.cmi typing/typetexp.cmi \
     typing/env.cmi typing/ctype.cmi asmcomp/compilenv.cmi \
     asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \
     asmcomp/asmgen.cmi driver/opterrors.cmi
-driver/opterrors.cmx: utils/warnings.cmx typing/typetexp.cmx \
+driver/opterrors.cmx : utils/warnings.cmx typing/typetexp.cmx \
     typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \
     typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \
     bytecomp/translclass.cmx parsing/syntaxerr.cmx driver/pparse.cmx \
@@ -784,135 +816,139 @@ driver/opterrors.cmx: utils/warnings.cmx typing/typetexp.cmx \
     typing/env.cmx typing/ctype.cmx asmcomp/compilenv.cmx \
     asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \
     asmcomp/asmgen.cmx driver/opterrors.cmi
-driver/optmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \
+driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
     driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \
-    driver/main_args.cmi utils/config.cmi utils/clflags.cmi \
-    asmcomp/asmpackager.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi \
-    asmcomp/arch.cmo driver/optmain.cmi
-driver/optmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \
+    driver/main_args.cmi parsing/location.cmi utils/config.cmi \
+    utils/clflags.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \
+    asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi
+driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
     driver/opterrors.cmx driver/optcompile.cmx utils/misc.cmx \
-    driver/main_args.cmx utils/config.cmx utils/clflags.cmx \
-    asmcomp/asmpackager.cmx asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx \
-    asmcomp/arch.cmx driver/optmain.cmi
-driver/pparse.cmo: utils/misc.cmi parsing/location.cmi utils/clflags.cmi \
+    driver/main_args.cmx parsing/location.cmx utils/config.cmx \
+    utils/clflags.cmx asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \
+    asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi
+driver/pparse.cmo : utils/misc.cmi parsing/location.cmi utils/clflags.cmi \
     utils/ccomp.cmi driver/pparse.cmi
-driver/pparse.cmx: utils/misc.cmx parsing/location.cmx utils/clflags.cmx \
+driver/pparse.cmx : utils/misc.cmx parsing/location.cmx utils/clflags.cmx \
     utils/ccomp.cmx driver/pparse.cmi
-toplevel/genprintval.cmi: typing/types.cmi typing/path.cmi \
+toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \
     typing/outcometree.cmi typing/env.cmi
-toplevel/opttopdirs.cmi: parsing/longident.cmi
-toplevel/opttoploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \
-    parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \
-    parsing/location.cmi typing/env.cmi
-toplevel/opttopmain.cmi:
-toplevel/topdirs.cmi: parsing/longident.cmi
-toplevel/toploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \
+toplevel/opttopdirs.cmi : parsing/longident.cmi
+toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \
+    typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \
+    parsing/longident.cmi parsing/location.cmi typing/env.cmi
+toplevel/opttopmain.cmi :
+toplevel/topdirs.cmi : parsing/longident.cmi
+toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
     parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \
     parsing/location.cmi typing/env.cmi
-toplevel/topmain.cmi:
-toplevel/trace.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \
+toplevel/topmain.cmi :
+toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \
     typing/env.cmi
-toplevel/expunge.cmo: bytecomp/symtable.cmi bytecomp/runtimedef.cmi \
+toplevel/expunge.cmo : bytecomp/symtable.cmi bytecomp/runtimedef.cmi \
     utils/misc.cmi typing/ident.cmi bytecomp/bytesections.cmi
-toplevel/expunge.cmx: bytecomp/symtable.cmx bytecomp/runtimedef.cmx \
+toplevel/expunge.cmx : bytecomp/symtable.cmx bytecomp/runtimedef.cmx \
     utils/misc.cmx typing/ident.cmx bytecomp/bytesections.cmx
-toplevel/genprintval.cmo: typing/types.cmi typing/printtyp.cmi \
+toplevel/genprintval.cmo : typing/types.cmi typing/printtyp.cmi \
     typing/predef.cmi typing/path.cmi typing/outcometree.cmi utils/misc.cmi \
     parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \
     typing/ctype.cmi typing/btype.cmi toplevel/genprintval.cmi
-toplevel/genprintval.cmx: typing/types.cmx typing/printtyp.cmx \
+toplevel/genprintval.cmx : typing/types.cmx typing/printtyp.cmx \
     typing/predef.cmx typing/path.cmx typing/outcometree.cmi utils/misc.cmx \
     parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \
     typing/ctype.cmx typing/btype.cmx toplevel/genprintval.cmi
-toplevel/opttopdirs.cmo: utils/warnings.cmi typing/types.cmi \
+toplevel/opttopdirs.cmo : utils/warnings.cmi typing/types.cmi \
     typing/printtyp.cmi typing/path.cmi toplevel/opttoploop.cmi \
     utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \
     typing/ctype.cmi utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \
     toplevel/opttopdirs.cmi
-toplevel/opttopdirs.cmx: utils/warnings.cmx typing/types.cmx \
+toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \
     typing/printtyp.cmx typing/path.cmx toplevel/opttoploop.cmx \
     utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \
     typing/ctype.cmx utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \
     toplevel/opttopdirs.cmi
-toplevel/opttoploop.cmo: utils/warnings.cmi typing/unused_var.cmi \
-    typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \
-    typing/typecore.cmi bytecomp/translmod.cmi bytecomp/simplif.cmi \
-    typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \
-    typing/predef.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
+toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \
+    typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
+    bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
+    bytecomp/printlambda.cmi parsing/printast.cmi typing/predef.cmi \
+    typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
     typing/outcometree.cmi driver/opterrors.cmi driver/optcompile.cmi \
     typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
     parsing/location.cmi parsing/lexer.cmi bytecomp/lambda.cmi \
     typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \
     asmcomp/compilenv.cmi utils/clflags.cmi typing/btype.cmi \
     asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi
-toplevel/opttoploop.cmx: utils/warnings.cmx typing/unused_var.cmx \
-    typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \
-    typing/typecore.cmx bytecomp/translmod.cmx bytecomp/simplif.cmx \
-    typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \
-    typing/predef.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
+toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \
+    typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
+    bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
+    bytecomp/printlambda.cmx parsing/printast.cmx typing/predef.cmx \
+    typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
     typing/outcometree.cmi driver/opterrors.cmx driver/optcompile.cmx \
     typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
     parsing/location.cmx parsing/lexer.cmx bytecomp/lambda.cmx \
     typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \
     asmcomp/compilenv.cmx utils/clflags.cmx typing/btype.cmx \
     asmcomp/asmlink.cmx asmcomp/asmgen.cmx toplevel/opttoploop.cmi
-toplevel/opttopmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \
+toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
     toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/opterrors.cmi \
-    utils/misc.cmi driver/main_args.cmi utils/config.cmi utils/clflags.cmi \
-    toplevel/opttopmain.cmi
-toplevel/opttopmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \
+    utils/misc.cmi driver/main_args.cmi parsing/location.cmi utils/config.cmi \
+    utils/clflags.cmi toplevel/opttopmain.cmi
+toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
     toplevel/opttoploop.cmx toplevel/opttopdirs.cmx driver/opterrors.cmx \
-    utils/misc.cmx driver/main_args.cmx utils/config.cmx utils/clflags.cmx \
-    toplevel/opttopmain.cmi
-toplevel/opttopstart.cmo: toplevel/opttopmain.cmi
-toplevel/opttopstart.cmx: toplevel/opttopmain.cmx
-toplevel/topdirs.cmo: utils/warnings.cmi typing/types.cmi toplevel/trace.cmi \
-    toplevel/toploop.cmi bytecomp/symtable.cmi typing/printtyp.cmi \
-    typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \
-    parsing/longident.cmi typing/ident.cmi typing/env.cmi bytecomp/dll.cmi \
-    typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \
+    utils/misc.cmx driver/main_args.cmx parsing/location.cmx utils/config.cmx \
+    utils/clflags.cmx toplevel/opttopmain.cmi
+toplevel/opttopstart.cmo : toplevel/opttopmain.cmi
+toplevel/opttopstart.cmx : toplevel/opttopmain.cmx
+toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \
+    toplevel/trace.cmi toplevel/toploop.cmi bytecomp/symtable.cmi \
+    typing/printtyp.cmi typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi \
+    bytecomp/meta.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \
+    bytecomp/dll.cmi typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \
     bytecomp/cmo_format.cmi utils/clflags.cmi toplevel/topdirs.cmi
-toplevel/topdirs.cmx: utils/warnings.cmx typing/types.cmx toplevel/trace.cmx \
-    toplevel/toploop.cmx bytecomp/symtable.cmx typing/printtyp.cmx \
-    typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \
-    parsing/longident.cmx typing/ident.cmx typing/env.cmx bytecomp/dll.cmx \
-    typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \
+toplevel/topdirs.cmx : utils/warnings.cmx typing/types.cmx \
+    toplevel/trace.cmx toplevel/toploop.cmx bytecomp/symtable.cmx \
+    typing/printtyp.cmx typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx \
+    bytecomp/meta.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \
+    bytecomp/dll.cmx typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \
     bytecomp/cmo_format.cmi utils/clflags.cmx toplevel/topdirs.cmi
-toplevel/toploop.cmo: utils/warnings.cmi typing/unused_var.cmi \
-    typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \
-    typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \
-    bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
-    bytecomp/printinstr.cmi parsing/printast.cmi typing/predef.cmi \
-    typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \
-    typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi \
-    parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \
-    typing/ident.cmi toplevel/genprintval.cmi driver/errors.cmi \
-    typing/env.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
+toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \
+    typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \
+    bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \
+    typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \
+    parsing/printast.cmi typing/predef.cmi typing/path.cmi \
+    parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \
+    typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \
+    parsing/location.cmi parsing/lexer.cmi typing/ident.cmi \
+    toplevel/genprintval.cmi driver/errors.cmi typing/env.cmi \
+    bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \
     utils/config.cmi driver/compile.cmi utils/clflags.cmi \
     bytecomp/bytegen.cmi typing/btype.cmi toplevel/toploop.cmi
-toplevel/toploop.cmx: utils/warnings.cmx typing/unused_var.cmx \
-    typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \
-    typing/typecore.cmx bytecomp/translmod.cmx bytecomp/symtable.cmx \
-    bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
-    bytecomp/printinstr.cmx parsing/printast.cmx typing/predef.cmx \
-    typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \
-    typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx \
-    parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \
-    typing/ident.cmx toplevel/genprintval.cmx driver/errors.cmx \
-    typing/env.cmx bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \
+toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \
+    typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \
+    bytecomp/translmod.cmx bytecomp/symtable.cmx bytecomp/simplif.cmx \
+    typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \
+    parsing/printast.cmx typing/predef.cmx typing/path.cmx \
+    parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \
+    typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \
+    parsing/location.cmx parsing/lexer.cmx typing/ident.cmx \
+    toplevel/genprintval.cmx driver/errors.cmx typing/env.cmx \
+    bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \
     utils/config.cmx driver/compile.cmx utils/clflags.cmx \
     bytecomp/bytegen.cmx typing/btype.cmx toplevel/toploop.cmi
-toplevel/topmain.cmo: utils/warnings.cmi toplevel/toploop.cmi \
+toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \
     toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \
-    driver/errors.cmi utils/config.cmi utils/clflags.cmi toplevel/topmain.cmi
-toplevel/topmain.cmx: utils/warnings.cmx toplevel/toploop.cmx \
+    parsing/location.cmi driver/errors.cmi utils/config.cmi utils/clflags.cmi \
+    toplevel/topmain.cmi
+toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \
     toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \
-    driver/errors.cmx utils/config.cmx utils/clflags.cmx toplevel/topmain.cmi
-toplevel/topstart.cmo: toplevel/topmain.cmi
-toplevel/topstart.cmx: toplevel/topmain.cmx
-toplevel/trace.cmo: typing/types.cmi toplevel/toploop.cmi typing/printtyp.cmi \
-    typing/predef.cmi typing/path.cmi utils/misc.cmi bytecomp/meta.cmi \
-    parsing/longident.cmi typing/ctype.cmi toplevel/trace.cmi
-toplevel/trace.cmx: typing/types.cmx toplevel/toploop.cmx typing/printtyp.cmx \
-    typing/predef.cmx typing/path.cmx utils/misc.cmx bytecomp/meta.cmx \
-    parsing/longident.cmx typing/ctype.cmx toplevel/trace.cmi
+    parsing/location.cmx driver/errors.cmx utils/config.cmx utils/clflags.cmx \
+    toplevel/topmain.cmi
+toplevel/topstart.cmo : toplevel/topmain.cmi
+toplevel/topstart.cmx : toplevel/topmain.cmx
+toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \
+    typing/printtyp.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \
+    bytecomp/meta.cmi parsing/longident.cmi typing/ctype.cmi \
+    toplevel/trace.cmi
+toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \
+    typing/printtyp.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \
+    bytecomp/meta.cmx parsing/longident.cmx typing/ctype.cmx \
+    toplevel/trace.cmi

diff --git a/.ignore b/.ignore
new file mode 100644 (file)
index 0000000..c801c47
--- /dev/null
+++ b/.ignore
@@ -0,0 +1,17 @@
+configure
+ocamlc
+ocamlc.opt
+expunge
+ocaml
+ocamlopt
+ocamlopt.opt
+ocamlcomp.sh
+ocamlcompopt.sh
+package-macosx
+_boot_log1
+_boot_log2
+_build
+_log
+myocamlbuild_config.ml
+ocamlbuild-mixed-boot
+ocamlnat

diff --git a/Changes b/Changes
index 2e7b5780dee42d3a80301d7b80b035d50d8c78dc..90030e8072fa02899d0710b9fc397a1388cf4b0e 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,181 @@
-Objective Caml 3.12.1:
-----------------------
+OCaml 4.00.0:
+-------------
+
+(Changes that can break existing programs are marked with a "*")
+
+- The official name of the language is now OCaml.
+
+Language features:
+- Added Generalized Abstract Data Types (GADTs) to the language. See
+  testsuite/tests/typing-gadts for the syntax and some examples of
+  use. Please use -principal for testing.
+- It is now possible to omit type annotations when packing and unpacking
+  first-class modules. The type-checker attempts to infer it from the context.
+  Using the -principal option guarantees forward compatibility.
+- New (module M) and (module M : S) syntax in patterns, for immediate
+  unpacking of a first-class module.
+
+Compilers:
+- Revised simplification of let-alias (PR#5205, PR#5288)
+- Better reporting of compiler version mismatch in .cmi files
+* Warning 28 is now enabled by default.
+- New option -absname to use absolute paths in error messages
+- Optimize away compile-time beta-redexes, e.g. (fun x y -> e) a b.
+
+Native-code compiler:
+- Optimized handling of partially-applied functions (PR#5287)
+- Small improvements in code generated for array bounds checks (PR#5345,
+  PR#5360).
+* New ARM backend (PR#5433):
+    . Supports both Linux/EABI (armel) and Linux/EABI+VFPv3 (armhf).
+    . Added support for the Thumb-2 instruction set with average code size
+      savings of 28%.
+    . Added support for position-independent code, natdynlink, profiling and
+      exception backtraces.
+- In -g mode, generation of CFI information and a few filename/line
+  number debugging annotations, enabling in particular precise stack
+  backtraces with the gdb debugger. Currently supported for x86 32-bits
+  and 64-bits only. (PR#5487)
+- New tool: ocamloptp, the equivalent of ocamlcp for the native-code compiler.
+
+Standard library:
+- Added float functions "hypot" and "copysign" (PR#3806, PR#4752, PR#5246)
+* Arg: options with empty doc strings are no longer included in the usage string
+  (PR#5437)
+- Array: faster implementations of "blit", "copy", "sub", "append" and "concat"
+  (PR#2395, PR#2787, PR#4591)
+* Hashtbl:
+    . Statistically-better generic hash function based on Murmur 3 (PR#5225)
+    . Fixed behavior of generic hash function w.r.t. -0.0 and NaN (PR#5222)
+    . Added optional "seed" parameter to Hashtbl.create for diversification
+    . Added new functorial interface "MakeSeeded" to support diversification
+      with user-provided hash functions.
+- Marshal: marshalling of function values (flag Marshal.Closures) now
+  also works for functions that come from dynamically-loaded modules (PR#5215)
+- Random:
+     . More random initialization (Random.self_init()), using /dev/urandom
+       when available (e.g. Linux, FreeBSD, MacOS X, Solaris)
+     . Faster implementation of Random.float
+- Scanf: new function "unescaped" (PR#3888)
+- Set and Map: more efficient implementation of "filter" and "partition"
+- String: new function "map" (PR#3888)
+
+Other libraries:
+- Bigarray: added "release" functions that free memory and file mappings
+  just like GC finalization does eventually, but does it immediately.
+
+Bug Fixes:
+- PR#1643: functions of the Lazy module whose named started with 'lazy_' have
+  been deprecated, and new ones without the prefix added
+- PR#3571: in Bigarrays, call msync() before unmapping to commit changes
+- PR#4549: Filename.dirname is not handling multiple / on Unix
+- PR#4688: (Windows) special floating-point values aren't converted to strings
+  correctly
+- PR#4697: Unix.putenv leaks memory on failure
+- PR#4705: camlp4 does not allow to define types with `True or `False
+- PR#4746: wrong detection of stack overflows in native code under Linux
+- PR#4869: rare collisions between assembly labels for code and data
+- PR#4880: "assert" constructs now show up in the exception stack backtrace
+- PR#4892: Array.set could raise "out of bounds" before evaluating 3rd arg
+- PR#4937: camlp4 incorrectly handles optional arguments if 'option' is
+  redefined
+- PR#5024: camlp4r now handles underscores in irrefutable patern matching of
+           records
+- PR#5064, PR#5485: try to ensure that 4K words of stack are available
+  before calling into C functions, raising a Stack_overflow exception
+  otherwise.  This reduces (but does not eliminate) the risk of
+  segmentation faults due to stack overflow in C code
+- PR#5211: updated Genlex documentation to state that camlp4 is mandatory for
+  'parser' keyword and associated notation
+- PR#5238, PR#5277: Sys_error when getting error location
+- PR#5295: OS threads: problem with caml_c_thread_unregister()
+- PR#5301: camlp4r and exception equal to another one with parameters
+- PR#5309: Queue.add is not thread/signal safe
+- PR#5310: Ratio.create_ratio/create_normalized_ratio have misleading names
+- PR#5311: better message for warning 23
+- PR#5313: ocamlopt -g misses optimizations
+- PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable
+- PR#5322: type abbreviations expanding to a universal type variable
+- PR#5325: (Windows) blocked Unix.recv in one thread blocks Unix.send in
+  another thread
+- PR#5327: (Windows) Unix.select blocks if same socket listed in first and
+  third arguments
+- PR#5328: under Windows, Unix.select leaves sockets in non-blocking mode
+- PR#5330: thread tag with '.top' and '.inferred.mli' targets
+- PR#5331: ocamlmktop is not always a shell script
+- PR#5335: Unix.environment segfaults after a call to clearenv
+- PR#5343: ocaml -rectypes is unsound wrt module subtyping
+- PR#5344: some predifined exceptions need special printing
+- PR#5356: ocamlbuild handling of 'predicates' for ocamlfind
+- PR#5364: wrong compilation of "((val m : SIG1) : SIG2)"
+- PR#5370: ocamldep omits filename in syntax error message
+- PR#5380: strange sscanf input segfault
+- PR#5394: Documentation for -dtypes is missing in manpage
+- PR#5416: (Windows) Unix.(set|clear)_close_on_exec now preserves blocking mode
+- PR#5436: update object ids on unmarshaling
+- PR#5453: configure doesn't find X11 under Ubuntu/MultiarchSpec
+- PR#5461: Double linking of bytecode modules
+- PR#5463: Bigarray.*.map_file fail if empty array is requested
+- PR#5469: private record type generated by functor loses abbreviation
+- PR#5475: Wrapper script for interpreted LablTk wrongly handles command line
+  parameters
+- PR#5476: bug in native code compilation of let rec on float arrays
+- PR#5498: Unification with an empty object only checks the absence of
+  the first method
+- PR#5503: error when ocamlbuild is passed an absolute path as build directory
+- PR#5509: misclassification of statically-allocated empty array that
+  falls exactly at beginning of an otherwise unused data page.
+- PR#5510: ocamldep has duplicate -ml{,i}-synonym options
+- PR#5511: in Bigarray.reshape, unwarranted limitation on new array dimensions.
+- PR#5513: Int64.div causes floating point exception (ocamlopt, x86)
+- PR#5516: in Bigarray C stubs, use C99 flexible array types if possible
+- PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file
+- PR#5538: combining -i and -annot in ocamlc
+- PR#5560: incompatible type for tuple pattern with -principal
+- problem with printing of string literals in camlp4 (reported on caml-list)
+- emacs mode: colorization of comments and strings now works correctly
+
+Feature wishes:
+- PR#352: new option "-stdin" to make ocaml read stdin as a script
+- PR#4444: new String.trim function, removing leading and trailing whistespace
+- PR#4898: new Sys.big_endian boolean for machine endianness
+- PR#5199: tests are run only for bytecode if either native support is missing,
+  or a non-empty value is set to "BYTECODE_ONLY" Makefile variable
+- PR#5236: new '%revapply' primitive with the semantics 'revapply x f = f x',
+    and '%apply' with semantics 'apply f x = f x'.
+- PR#5297: compiler now checks existence of builtin primitives
+- PR#5329: (Windows) more efficient Unix.select if all fd's are sockets
+- PR#5358: first class modules don't allow "with type" declarations for types
+  in sub-modules
+- PR#5397: Filename.temp_dir_name should be mutable
+- PR#5411: new directive for the toplevel: #load_rec
+- PR#5420: Unix.openfile share mode (Windows)
+- PR#5437: warning for useless open statements
+- PR#5438: new warnings for unused declarations
+- PR#5454: Digest.compare is missing and md5 doc update
+- PR#5467: no extern "C" into ocaml C-stub headers
+- PR#5478: ocamlopt assumes ar command exists
+- PR#5479: Num.num_of_string may raise an exception, not reflected in the
+  documentation.
+- ocamldebug: ability to inspect values that contain code pointers
+- ocamldebug: new 'environment' directive to set environment variables
+  for debugee
+
+Shedding weight:
+* Removed the obsolete native-code generators for Alpha, HPPA, IA64 and MIPS.
+* The "DBM" library (interface with Unix DBM key-value stores) is no
+  longer part of this distribution.  It now lives its own life at
+  https://forge.ocamlcore.org/projects/camldbm/
+* The "OCamlWin" toplevel user interface for MS Windows is no longer
+  part of this distribution.  It now lives its own life at
+  https://forge.ocamlcore.org/projects/ocamltopwin/
+  
+Other changes:
+- Copy VERSION file to library directory when installing.
+
+
+OCaml 3.12.1:
+-------------
 
 Bug fixes:
 - PR#4345, PR#4767: problems with camlp4 printing of float values
@@ -95,6 +271,7 @@ Other changes:
 - Added new operation 'compare_ext' to custom blocks, called when
   comparing a custom block value with an unboxed integer.
 
+
 Objective Caml 3.12.0:
 ----------------------
 
@@ -172,7 +349,7 @@ Compilers and toplevel:
   caused by the incomplete comparison of applicative paths F(X).t.
 
 Native-code compiler:
-- AMD64: shorter and slightly more efficient code generated for 
+- AMD64: shorter and slightly more efficient code generated for
   float comparisons.
 
 Standard library:
@@ -2720,5 +2897,3 @@ Caml Special Light 1.06:
 ------------------------
 
 * First public release.
-
-$Id$

diff --git a/INSTALL b/INSTALL
index d73657fa642cd7a70eff7a3749ed761f3f03ddd8..0e7091926b0764bdf997731176ce4a727dba3426 100644 (file)
--- a/INSTALL
+++ b/INSTALL
@@ -1,5 +1,5 @@
-            Installing Objective Caml on a Unix machine
-            -------------------------------------------
+            Installing OCaml on a Unix machine
+            ----------------------------------
 
 PREREQUISITES
 
@@ -43,18 +43,21 @@ in the config/ subdirectory.
 
 The "configure" script accepts the following options:
 
--bindir <dir>                   (default: /usr/local/bin)
-        Directory where the binaries will be installed
+-prefix <dir>                   (default: /usr/local)
+        Set the PREFIX variable used to define the defaults of the
+        following three options.  Must be an absolute path name.
 
--libdir <dir>                   (default: /usr/local/lib/ocaml)
-        Directory where the Caml library will be installed
+-bindir <dir>                   (default: $(PREFIX)/bin)
+        Directory where the binaries will be installed.
+        Must be an absolute path name, or start with "$(PREFIX)"
 
--mandir <dir>                   (default: /usr/local/man/man1)
-        Directory where the manual pages will be installed
+-libdir <dir>                   (default: $(PREFIX)/lib/ocaml)
+        Directory where the OCaml library will be installed
+        Must be an absolute path name, or start with "$(PREFIX)"
 
--prefix <dir>                   (default: /usr/local)
-        Set bindir, libdir and mandir to
-        <dir>/bin, <dir>/lib/ocaml, <dir>/man/man1 respectively.
+-mandir <dir>                   (default: $(PREFIX)/man/man1)
+        Directory where the manual pages will be installed
+        Must be an absolute path name, or start with "$(PREFIX)"
 
 -cc <C compiler and options>    (default: gcc if available, cc otherwise)
         C compiler to use for building the system
@@ -67,10 +70,11 @@ The "configure" script accepts the following options:
 
 -host <hosttype>                (default: determined automatically)
         The type of the host machine, in GNU's "configuration name"
-        format (CPU-COMPANY-SYSTEM). This info is generally determined
-        automatically by the "configure" script, and rarely ever
-        needs to be provided by hand. The installation instructions
-        for gcc or emacs contain a complete list of configuration names.
+        format (CPU-COMPANY-SYSTEM or CPU-COMPANY-KERNEL-SYSTEM).
+        This info is generally determined automatically by the
+        "configure" script, and rarely ever needs to be provided by
+        hand. The installation instructions for gcc or emacs contain a
+        complete list of configuration names.
 
 -x11include <include_dir>       (default: determined automatically)
 -x11lib     <lib_dir>           (default: determined automatically)
@@ -119,10 +123,24 @@ The "configure" script accepts the following options:
         run-time system manually written in assembly language.
         This assembler must preprocess its input with the C preprocessor.
 
+-with-debug-runtime
+        Compile and install the debug version of the runtimes, useful
+        for debugging C stubs and other low-level code.
+
 -verbose
         Verbose output of the configuration tests. Use it if the outcome
         of configure is not what you were expecting.
 
+-no-camlp4
+        Do not compile Camlp4.
+
+-no-graph
+        Do not compile the Graphics library.
+
+-partialld <linker and options>  (default: determined automatically)
+        The linker and options to use for producing an object file
+        (rather than an executable) from several other object files.
+
 Examples:
 
   Standard installation in /usr/{bin,lib,man} instead of /usr/local:
@@ -130,6 +148,8 @@ Examples:
 
   Installation in /usr, man pages in section "l":
     ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl
+  or:
+    ./configure -prefix /usr -mandir '$(PREFIX)/man/manl'
 
   On a MacOSX 10.5/Intel Core 2 or MacOSX 10.5/PowerPC host,
   to build a 64-bit version of OCaml:
@@ -142,7 +162,7 @@ Examples:
     ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c"
 
   On a Linux x86/64 bits host, to build the run-time system in PIC mode
-  (enables putting the runtime in a shared library, 
+  (enables putting the runtime in a shared library,
    at a small performance cost):
     ./configure -cc "gcc -fPIC" -aspp "gcc -c -fPIC"
 
@@ -166,15 +186,15 @@ for guidance on how to edit the generated files by hand.
 
         make world
 
-This builds the Objective Caml bytecode compiler for the first time.
-This phase is fairly verbose; consider redirecting the output to a file:
+This builds the OCaml bytecode compiler for the first time.  This
+phase is fairly verbose; consider redirecting the output to a file:
 
         make world > log.world 2>&1     # in sh
         make world >& log.world         # in csh
 
 3- (Optional) To be sure everything works well, you can try to
-bootstrap the system --- that is, to recompile all Objective Caml
-sources with the newly created compiler. From the top directory, do:
+bootstrap the system --- that is, to recompile all OCaml sources with
+the newly created compiler. From the top directory, do:
 
         make bootstrap
 
@@ -201,9 +221,9 @@ or:
         make opt > log.opt 2>&1     # in sh
         make opt >& log.opt         # in csh
 
-5- Compile fast versions of the Objective Caml compilers, by
-compiling them with the native-code compiler (you have only compiled
-them to bytecode so far).  Just do:
+5- Compile fast versions of the OCaml compilers, by compiling them
+with the native-code compiler (you have only compiled them to bytecode
+so far).  Just do:
 
         make opt.opt
 
@@ -222,7 +242,7 @@ An alternative, and faster approach to steps 2 to 5 is
 The result is equivalent to "make world opt opt.opt", but this may
 fail if anything goes wrong in native-code generation.
 
-6- You can now install the Objective Caml system. This will create the
+6- You can now install the OCaml system. This will create the
 following commands (in the binary directory selected during
 autoconfiguration):
 
@@ -233,9 +253,9 @@ autoconfiguration):
         ocamllex         the lexer generator
         ocaml            the interactive, toplevel-based system
         ocamlmktop       a tool to make toplevel systems that integrate
-                         user-defined C primitives and Caml code
+                         user-defined C primitives and OCaml code
         ocamldebug       the source-level replay debugger
-        ocamldep         generator of "make" dependencies for Caml sources
+        ocamldep         generator of "make" dependencies for OCaml sources
         ocamldoc         documentation generator
         ocamlprof        execution count profiler
         ocamlcp          the bytecode compiler in profiling mode
@@ -255,8 +275,8 @@ From the top directory, become superuser and do:
 directory, do "make clean".
 
 8- (Optional) The emacs/ subdirectory contains Emacs-Lisp files for an
-Objective Caml editing mode and an interface for the debugger.  To
-install these files, change to the emacs/ subdirectory and do
+OCaml editing mode and an interface for the debugger.  To install
+these files, change to the emacs/ subdirectory and do
 
         make EMACSDIR=<directory where to install the files> install
 or
@@ -267,7 +287,7 @@ In the latter case, the destination directory defaults to the
 
 9- After installation, do *not* strip the ocamldebug and ocamlbrowser
 executables.  (These are mixed-mode executables, containing both
-compiled C code and Caml bytecode; stripping erases the bytecode!)
+compiled C code and OCaml bytecode; stripping erases the bytecode!)
 Other executables such as ocamlrun can safely be stripped.
 
 IF SOMETHING GOES WRONG:

diff --git a/Makefile b/Makefile
index 912259b7baeb624cb8cb7b4be31dde4571ee714c..73894ea24a8acebed68381fcb04c24084702e1a7 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -31,6 +31,9 @@ CAMLRUN=byterun/ocamlrun
 SHELL=/bin/sh
 MKDIR=mkdir -p
 
+CAMLP4OUT=$(CAMLP4:=out)
+CAMLP4OPT=$(CAMLP4:=opt)
+
 INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
         -I toplevel
 
@@ -40,11 +43,11 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
 
 OPTUTILS=$(UTILS)
 
-PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
+PARSING=parsing/location.cmo parsing/longident.cmo \
   parsing/syntaxerr.cmo parsing/parser.cmo \
   parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
 
-TYPING=typing/unused_var.cmo typing/ident.cmo typing/path.cmo \
+TYPING=typing/ident.cmo typing/path.cmo \
   typing/primitive.cmo typing/types.cmo \
   typing/btype.cmo typing/oprint.cmo \
   typing/subst.cmo typing/predef.cmo \
@@ -52,8 +55,8 @@ TYPING=typing/unused_var.cmo typing/ident.cmo typing/path.cmo \
   typing/typedtree.cmo typing/ctype.cmo \
   typing/printtyp.cmo typing/includeclass.cmo \
   typing/mtype.cmo typing/includecore.cmo \
-  typing/includemod.cmo typing/parmatch.cmo \
-  typing/typetexp.cmo typing/stypes.cmo typing/typecore.cmo \
+  typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
+  typing/stypes.cmo typing/typecore.cmo \
   typing/typedecl.cmo typing/typeclass.cmo \
   typing/typemod.cmo
 
@@ -71,7 +74,7 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \
 ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \
   asmcomp/cmm.cmo asmcomp/printcmm.cmo \
   asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \
-  asmcomp/clambda.cmo asmcomp/compilenv.cmo \
+  asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \
   asmcomp/closure.cmo asmcomp/cmmgen.cmo \
   asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \
   asmcomp/comballoc.cmo asmcomp/liveness.cmo \
@@ -113,6 +116,7 @@ OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER)
 EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \
   utils/config.cmo utils/clflags.cmo \
   typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \
+  utils/warnings.cmo parsing/location.cmo \
   typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \
   bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo toplevel/expunge.cmo
 
@@ -130,7 +134,7 @@ defaultentry:
 
 # Recompile the system using the bootstrap compiler
 all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \
-  otherlibraries ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc
+  otherlibraries ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc
 
 # Compile everything the first time
 world:
@@ -141,6 +145,7 @@ world:
 world.opt:
        $(MAKE) coldstart
        $(MAKE) opt.opt
+       $(MAKE) ocamltoolsopt
 
 # Hard bootstrap how-to:
 # (only necessary in some cases, for example if you remove some primitive)
@@ -259,16 +264,17 @@ opt:
        $(MAKE) ocamlopt
        $(MAKE) libraryopt
        $(MAKE) otherlibrariesopt
+       $(MAKE) ocamltoolsopt
        $(MAKE) ocamlbuildlib.native
 
 # Native-code versions of the tools
 opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \
-        ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \
-        otherlibrariesopt \
-        ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt
+        $(DEBUGGER) ocamldoc ocamlbuild.byte $(CAMLP4OUT) \
+        ocamlopt.opt otherlibrariesopt ocamllex.opt ocamltoolsopt.opt \
+        ocamldoc.opt ocamlbuild.native $(CAMLP4OPT)
 
 base.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \
-        ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \
+        ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc ocamlopt.opt \
         otherlibrariesopt
 
 # Installation
@@ -278,8 +284,9 @@ install:
        if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi
        if test -d $(MANDIR)/man$(MANEXT); then : ; \
          else $(MKDIR) $(MANDIR)/man$(MANEXT); fi
+       cp VERSION $(LIBDIR)/
        cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \
-         dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \
+         dllthreads.so dllunix.so dllgraphics.so dllstr.so \
          dlltkanim.so
        cd byterun; $(MAKE) install
        cp ocamlc $(BINDIR)/ocamlc$(EXE)
@@ -320,6 +327,7 @@ installopt:
          then cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE); else :; fi
        if test -f lex/ocamllex.opt; \
          then cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE); else :; fi
+       cd tools; $(MAKE) installopt
 
 clean:: partialclean
 
@@ -382,6 +390,7 @@ utils/config.ml: utils/config.mlp config/Makefile
            -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \
            -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \
            -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
+           -e 's|%%ARCMD%%|$(ARCMD)|' \
            -e 's|%%CC_PROFILE%%|$(CC_PROFILE)|' \
            -e 's|%%ARCH%%|$(ARCH)|' \
            -e 's|%%MODEL%%|$(MODEL)|' \
@@ -392,6 +401,7 @@ utils/config.ml: utils/config.mlp config/Makefile
            -e 's|%%EXT_DLL%%|.so|' \
            -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \
            -e 's|%%ASM%%|$(ASM)|' \
+           -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \
            -e 's|%%MKDLL%%|$(MKDLL)|' \
            -e 's|%%MKEXE%%|$(MKEXE)|' \
            -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
@@ -423,16 +433,6 @@ partialclean::
 
 beforedepend:: parsing/lexer.ml
 
-# The auxiliary lexer for counting line numbers
-
-parsing/linenum.ml: parsing/linenum.mll
-       $(CAMLLEX) parsing/linenum.mll
-
-partialclean::
-       rm -f parsing/linenum.ml
-
-beforedepend:: parsing/linenum.ml
-
 # The bytecode compiler compiled with the native-code compiler
 
 ocamlc.opt: $(COMPOBJS:.cmo=.cmx)
@@ -627,6 +627,9 @@ clean::
 ocamltools: ocamlc ocamlyacc ocamllex asmcomp/cmx_format.cmi
        cd tools; $(MAKE) all
 
+ocamltoolsopt: ocamlopt
+       cd tools; $(MAKE) opt
+
 ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex asmcomp/cmx_format.cmi
        cd tools; $(MAKE) opt.opt
 
@@ -686,7 +689,7 @@ alldepend::
 
 # Camlp4
 
-camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte
+camlp4out: ocamlc ocamlbuild.byte
        ./build/camlp4-byte-only.sh
 
 camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
@@ -694,19 +697,20 @@ camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
 
 # Ocamlbuild
 
-ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot
+ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot
        ./build/ocamlbuild-byte-only.sh
 
-ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot
+ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot
        ./build/ocamlbuild-native-only.sh
-ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot
+ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot
        ./build/ocamlbuildlib-native-only.sh
 
-ocamlbuild-mixed-boot: ocamlc otherlibraries
+ocamlbuild-mixed-boot: ocamlc
        ./build/mixed-boot.sh
+       touch ocamlbuild-mixed-boot
 
 partialclean::
-       rm -rf _build
+       rm -rf _build ocamlbuild-mixed-boot
 
 # Check that the stack limit is reasonable.
 
@@ -717,6 +721,11 @@ checkstack:
        fi
        @rm -f tools/checkstack
 
+# Make clean in the test suite
+
+clean::
+       cd testsuite; $(MAKE) clean
+
 # Make MacOS X package
 
 package-macosx:
@@ -762,8 +771,8 @@ distclean:
 .PHONY: coreboot defaultentry depend distclean install installopt
 .PHONY: library library-cross libraryopt ocamlbuild-mixed-boot
 .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc
-.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt
-.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries
+.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltoolsopt
+.PHONY: ocamltoolsopt.opt ocamlyacc opt-core opt opt.opt otherlibraries
 .PHONY: otherlibrariesopt package-macosx promote promote-cross
 .PHONY: restore runtime runtimeopt makeruntimeopt world world.opt
 

diff --git a/Makefile.nt b/Makefile.nt
index a7e34f59932a68199b6a145a00839d6cc1bd2e30..0b9e4e7c2f20bfe60af2042a256dcba85720232d 100644 (file)
--- a/Makefile.nt
+++ b/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -28,6 +28,9 @@ CAMLDEP=boot/ocamlrun tools/ocamldep
 DEPFLAGS=$(INCLUDES)
 CAMLRUN=byterun/ocamlrun
 
+CAMLP4OUT=$(CAMLP4:=out)
+CAMLP4OPT=$(CAMLP4:=opt)
+
 INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \
         -I toplevel
 
@@ -37,11 +40,11 @@ UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \
 
 OPTUTILS=$(UTILS)
 
-PARSING=parsing/linenum.cmo parsing/location.cmo parsing/longident.cmo \
+PARSING=parsing/location.cmo parsing/longident.cmo \
   parsing/syntaxerr.cmo parsing/parser.cmo \
   parsing/lexer.cmo parsing/parse.cmo parsing/printast.cmo
 
-TYPING=typing/unused_var.cmo typing/ident.cmo typing/path.cmo \
+TYPING=typing/ident.cmo typing/path.cmo \
   typing/primitive.cmo typing/types.cmo \
   typing/btype.cmo typing/oprint.cmo \
   typing/subst.cmo typing/predef.cmo \
@@ -110,9 +113,9 @@ OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER)
 EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \
   utils/config.cmo utils/clflags.cmo \
   typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \
+  utils/warnings.cmo parsing/location.cmo \
   typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \
-  bytecomp/dll.cmo \
-  bytecomp/symtable.cmo toplevel/expunge.cmo
+  bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo toplevel/expunge.cmo
 
 PERVASIVES=$(STDLIB_MODULES) topdirs toploop outcometree
 
@@ -121,7 +124,8 @@ defaultentry:
        @echo "Please refer to the installation instructions in file README.win32."
 
 # Recompile the system using the bootstrap compiler
-all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte ocamlbuild.byte camlp4out $(DEBUGGER) win32gui
+all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \
+  otherlibraries ocamldoc.byte ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) 
 
 # The compilation of ocaml will fail if the runtime has changed.
 # Never mind, just do make bootstrap to reach fixpoint again.
@@ -211,7 +215,7 @@ opt: opt-core otherlibrariesopt ocamlbuildlib.native
 
 # Native-code versions of the tools
 opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
-        ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt
+        ocamltoolsopt.opt ocamlbuild.native $(CAMLP4OPT) ocamldoc.opt
 
 # Complete build using fast compilers
 world.opt: coldstart opt.opt
@@ -239,7 +243,6 @@ installbyt:
        for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done
        if test -f debugger/ocamldebug.exe; then (cd debugger; $(MAKEREC) install); \
           else :; fi
-       cd win32caml ; $(MAKE) install
        ./build/partial-install.sh
        cp config/Makefile $(LIBDIR)/Makefile.config
        cp README $(DISTRIB)/Readme.general.txt
@@ -323,6 +326,7 @@ utils/config.ml: utils/config.mlp config/Makefile
            -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \
            -e "s|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|" \
            -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \
+           -e 's|%%ARCMD%%|$(ARCMD)|' \
            -e 's|%%BINUTILS_NM%%|$(BINUTILS_NM)|' \
            -e 's|%%BINUTILS_OBJCOPY%%|$(BINUTILS_OBJCOPY)|' \
            -e "s|%%ARCH%%|$(ARCH)|" \
@@ -334,6 +338,7 @@ utils/config.ml: utils/config.mlp config/Makefile
            -e "s|%%EXT_DLL%%|.dll|" \
            -e "s|%%SYSTHREAD_SUPPORT%%|true|" \
            -e 's|%%ASM%%|$(ASM)|' \
+           -e 's|%%ASM_CFI_SUPPORTED%%|false|' \
            -e 's|%%MKDLL%%|$(MKDLL)|' \
            -e 's|%%MKEXE%%|$(MKEXE)|' \
            -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \
@@ -366,16 +371,6 @@ partialclean::
 
 beforedepend:: parsing/lexer.ml
 
-# The auxiliary lexer for counting line numbers
-
-parsing/linenum.ml: parsing/linenum.mll
-       $(CAMLLEX) parsing/linenum.mll
-
-partialclean::
-       rm -f parsing/linenum.ml
-
-beforedepend:: parsing/linenum.ml
-
 # The bytecode compiler compiled with the native-code compiler
 
 ocamlc.opt: $(COMPOBJS:.cmo=.cmx)
@@ -442,15 +437,13 @@ partialclean::
 beforedepend:: asmcomp/arch.ml
 
 ifeq ($(TOOLCHAIN),msvc)
-ASMCOMP_PROC=asmcomp/$(ARCH)/proc_nt.ml
 ASMCOMP_EMIT=asmcomp/$(ARCH)/emit_nt.mlp
 else
-ASMCOMP_PROC=asmcomp/$(ARCH)/proc.ml
 ASMCOMP_EMIT=asmcomp/$(ARCH)/emit.mlp
 endif
 
-asmcomp/proc.ml: $(ASMCOMP_PROC)
-       cp $(ASMCOMP_PROC) asmcomp/proc.ml
+asmcomp/proc.ml: asmcomp/$(ARCH)/proc.ml
+       cp asmcomp/$(ARCH)/proc.ml asmcomp/proc.ml
 
 partialclean::
        rm -f asmcomp/proc.ml
@@ -626,14 +619,6 @@ ocamlbuild-mixed-boot:
 partialclean::
        rm -rf _build
 
-# The Win32 toplevel GUI
-
-win32gui:
-       cd win32caml ; $(MAKE) all
-
-clean::
-       cd win32caml ; $(MAKE) clean
-
 # Default rules
 
 .SUFFIXES: .ml .mli .cmo .cmi .cmx
@@ -664,4 +649,18 @@ depend: beforedepend
 
 alldepend:: depend
 
+distclean:
+       ./build/distclean.sh
+
+.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean
+.PHONY: partialclean beforedepend alldepend cleanboot coldstart
+.PHONY: compare core coreall
+.PHONY: coreboot defaultentry depend distclean install installopt
+.PHONY: library library-cross libraryopt ocamlbuild-mixed-boot
+.PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc
+.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt
+.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries
+.PHONY: otherlibrariesopt promote promote-cross
+.PHONY: restore runtime runtimeopt makeruntimeopt world world.opt
+
 include .depend

diff --git a/README b/README
index 5933521d4f43d99c87aeee59b9e6fbe59188fc2b..6090041f5dd3e9e8a77ac61976ed03404e04731a 100644 (file)
--- a/README
+++ b/README
@@ -1,17 +1,17 @@
 OVERVIEW:
 
-Objective Caml is an implementation of the ML language, based on
-the Caml Light dialect extended with a complete class-based object system
-and a powerful module system in the style of Standard ML.
-
-Objective Caml comprises two compilers. One generates bytecode
-which is then interpreted by a C program. This compiler runs quickly,
-generates compact code with moderate memory requirements, and is
-portable to essentially any 32 or 64 bit Unix platform. Performance of
-generated programs is quite good for a bytecoded implementation.
-This compiler can be used either as a standalone, batch-oriented
-compiler that produces standalone programs, or as an interactive,
-toplevel-based system.
+OCaml is an implementation of the ML language, based on the Caml Light
+dialect extended with a complete class-based object system and a
+powerful module system in the style of Standard ML.
+
+OCaml comprises two compilers. One generates bytecode which is then
+interpreted by a C program. This compiler runs quickly, generates
+compact code with moderate memory requirements, and is portable to
+essentially any 32 or 64 bit Unix platform. Performance of generated
+programs is quite good for a bytecoded implementation.  This compiler
+can be used either as a standalone, batch-oriented compiler that
+produces standalone programs, or as an interactive, toplevel-based
+system.
 
 The other compiler generates high-performance native code for a number
 of processors. Compilation takes longer and generates bigger code, but
@@ -19,31 +19,27 @@ the generated programs deliver excellent performance, while retaining
 the moderate memory requirements of the bytecode compiler. The
 native-code compiler currently runs on the following platforms:
 
-Tier 1 (actively used and maintained by the core Caml team):
+Tier 1 (actively used and maintained by the core OCaml team):
 
     AMD64 (Opteron)    Linux, MacOS X, MS Windows
     IA32 (Pentium)     Linux, FreeBSD, MacOS X, MS Windows
-    PowerPC            MacOS X
+    PowerPC            Linux, MacOS X
+    ARM                Linux
 
 Tier 2 (maintained when possible, with help from users):
 
-    Alpha              Digital Unix/Compaq Tru64, Linux, all BSD
     AMD64              FreeBSD, OpenBSD
-    HP PA-RISC         HPUX 11, Linux
     IA32 (Pentium)     NetBSD, OpenBSD, Solaris 9
-    IA64               Linux, FreeBSD
-    MIPS               IRIX 6
-    PowerPC            Linux, NetBSD
-    SPARC              Solaris 9, Linux, NetBSD
-    Strong ARM         Linux
+    PowerPC            NetBSD
+    SPARC              Solaris, Linux, NetBSD
 
 Other operating systems for the processors above have not been tested,
 but the compiler may work under other operating systems with little work.
 
-Before the introduction of objects, Objective Caml was known as Caml
-Special Light. Objective Caml is almost upwards compatible with Caml
-Special Light, except for a few additional reserved keywords that have
-forced some renaming of standard library functions.
+Before the introduction of objects, OCaml was known as Caml Special
+Light. OCaml is almost upwards compatible with Caml Special Light,
+except for a few additional reserved keywords that have forced some
+renaming of standard library functions.
 
 CONTENTS:
 
@@ -52,7 +48,7 @@ CONTENTS:
   LICENSE               license and copyright notice
   Makefile              main Makefile
   README                this file
-  README.win32          infos on the MS Windows ports of O.Caml
+  README.win32          infos on the MS Windows ports of OCaml
   asmcomp/              native-code compiler and linker
   asmrun/               native-code runtime library
   boot/                 bootstrap compiler
@@ -62,7 +58,7 @@ CONTENTS:
   config/               autoconfiguration stuff
   debugger/             source-level replay debugger
   driver/               driver code for the compilers
-  emacs/                Caml editing mode and debugger interface for GNU Emacs
+  emacs/                OCaml editing mode and debugger interface for GNU Emacs
   lex/                  lexer generator
   maccaml/              the Macintosh GUI
   ocamldoc/             documentation generator
@@ -79,8 +75,9 @@ COPYRIGHT:
 
 All files marked "Copyright INRIA" in this distribution are copyright
 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-2007, 2008 Institut National de Recherche en Informatique et en Automatique
-(INRIA) and distributed under the conditions stated in file LICENSE.
+2007, 2008, 2009, 2010, 2011, 2012 Institut National de Recherche en
+Informatique et en Automatique (INRIA) and distributed under the
+conditions stated in file LICENSE.
 
 INSTALLATION:
 
@@ -89,24 +86,24 @@ MacOS X machines.  For MS Windows, see README.win32.
 
 DOCUMENTATION:
 
-The Objective Caml manual is distributed in HTML, PDF, Postscript,
-DVI, and Emacs Info files.  It is available on the World Wide Web, at
+The OCaml manual is distributed in HTML, PDF, Postscript, DVI, and
+Emacs Info files.  It is available on the World Wide Web, at
 
         http://caml.inria.fr/
 
 AVAILABILITY:
 
-The complete Objective Caml distribution can be accessed at
+The complete OCaml distribution can be accessed at
 
         http://caml.inria.fr/
 
 KEEPING IN TOUCH WITH THE CAML COMMUNITY:
 
-There exists a mailing list of users of the Caml implementations
+There exists a mailing list of users of the OCaml implementations
 developed at INRIA. The purpose of this list is to share
 experience, exchange ideas (and even code), and report on applications
-of the Caml language. Messages can be written in English or in
-French. The list has about 750 subscribers.
+of the OCaml language. Messages can be written in English or in
+French. The list has more than 1000 subscribers.
 
 Messages to the list should be sent to:
 
@@ -114,13 +111,13 @@ Messages to the list should be sent to:
 
 You can subscribe to this list via the Web interface at
 
-    http://yquem.inria.fr/cgi-bin/mailman/listinfo/caml-list
+        https://sympa-roc.inria.fr/wws/info/caml-list
 
-Archives of the list are available on the Web site http://caml.inria.fr/
+Archives of the list are available on the Web site above.
 
 The Usenet news groups comp.lang.ml and comp.lang.functional
 also contains discussions about the ML family of programming languages,
-including Caml.
+including OCaml.
 
 BUG REPORTS AND USER FEEDBACK:
 

diff --git a/README.win32 b/README.win32
index 27ee0851375f39af78aef7fbe7402b0e203211d2..6f21ecb531446d81527d6a2f369fbdf9ddaa075d 100644 (file)
--- a/README.win32
+++ b/README.win32
@@ -1,9 +1,11 @@
-       Release notes on the MS Windows ports of Objective Caml
-       -------------------------------------------------------
+       Release notes on the MS Windows ports of OCaml
+       ----------------------------------------------
 
-There are no less than four ports of Objective Caml for MS Windows available:
+There are no less than four ports of OCaml for MS Windows available:
   - a native Win32 port, built with the Microsoft development tools;
-  - a native Win32 port, built with the Cygwin/MinGW development tools;
+  - a native Win32 port, built with the 32-bit version of the gcc
+    compiler from the mingw-w64 project, packaged in Cygwin
+    (under the name mingw64-i686);
   - a port consisting of the Unix sources compiled under the Cygwin
     Unix-like environment for Windows;
   - a native Win64 port (64-bit Windows), built with the Microsoft
@@ -57,7 +59,7 @@ runs without any additional tools.
 The native-code compiler (ocamlopt) requires the Microsoft Windows SDK
 (item [1]) and the flexdll tool (item [2]).
 
-Statically linking Caml bytecode with C code (ocamlc -custom) also requires
+Statically linking OCaml bytecode with C code (ocamlc -custom) also requires
 items [1] and [2].
 
 The LablTk GUI requires Tcl/Tk 8.5 (item [3]).
@@ -85,7 +87,7 @@ THIRD-PARTY SOFTWARE:
     http://www.microsoft.com/downloads/en/default.aspx
     under the name "Microsoft Windows 7 SDK".
 
-[2] flexdll version 0.23 or later.
+[2] flexdll version 0.29 or later.
     Can be downloaded from http://alain.frisch.fr/flexdll.html
 
 [3] TCL/TK version 8.5.  Windows binaries are available as part of the
@@ -104,7 +106,8 @@ You will need the following software components to perform the recompilation:
   Make sure to install the 32-bit version of TCL/TK, even if you are
   compiling on a 64-bit Windows.
 - The Cygwin port of GNU tools, available from http://www.cygwin.com/
-  Install at least the following packages: diffutils, make, ncurses.
+  Install at least the following packages (and their dependencies):
+  diffutils, make, ncurses.
 
 First, you need to set up your cygwin environment for using the MS
 tools.  The following assumes that you have installed [1], [2], and [3]
@@ -119,13 +122,14 @@ to adjust the paths accordingly.
 
   Then enter the following commands:
     cd "%PFPATH%\Microsoft Visual Studio 9.0\VC\bin"
+    set FLEXDLLDIR=%PFPATH%\flexdll
     vcvars32
     echo VCPATH="`cygpath -p '%Path%'`" >C:\cygwin\tmp\msenv
     echo LIB="%LIB%;C:\Tcl\lib" >>C:\cygwin\tmp\msenv
     echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv
-    echo INCLUDE="%INCLUDE%;C:\Tcl\include" >>C:\cygwin\tmp\msenv
-    echo FLPATH="`cygpath '%PFPATH%\flexdll'`" >>C:\cygwin\tmp\msenv
-    echo PATH="${VCPATH}:$PATH:${FLPATH}" >>C:\cygwin\tmp\msenv
+    echo INCLUDE="%INCLUDE%;%FLEXDLLDIR%;C:\Tcl\include" >>C:\cygwin\tmp\msenv
+    echo FLPATH="`cygpath '%FLEXDLLDIR%'`" >>C:\cygwin\tmp\msenv
+    echo PATH="$VCPATH:$FLPATH:$PATH" >>C:\cygwin\tmp\msenv
     echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv
     echo export OCAMLBUILD_FIND=/usr/bin/find >>C:\cygwin\tmp\msenv
 
@@ -171,22 +175,15 @@ Unix/GCC or Cygwin or Mingw on similar hardware.
 
 CREDITS:
 
-The initial port of Caml Special Light (the ancestor of Objective Caml)
-to Windows NT was done by Kevin Gallo at Microsoft Research, who
-kindly contributed his changes to the Caml project.
-
-The graphical user interface for the toplevel was initially developed
-by Jacob Navia, then significantly improved by Christopher A. Watford.
+The initial port of Caml Special Light (the ancestor of OCaml) to
+Windows NT was done by Kevin Gallo at Microsoft Research, who kindly
+contributed his changes to the OCaml project.
 
 ------------------------------------------------------------------------------
 
            The native Win32 port built with Mingw
            --------------------------------------
 
-NOTE: Due to changes in cygwin's compilers, this port is not available
-in OCaml 3.12.1.  A patch will be made available soon after the release
-of 3.12.1.
-
 REQUIREMENTS:
 
 This port runs under MS Windows Vista, XP, and 2000.
@@ -195,18 +192,34 @@ The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...)
 runs without any additional tools.
 
 The native-code compiler (ocamlopt), as well as static linking of
-Caml bytecode with C code (ocamlc -custom), require
+OCaml bytecode with C code (ocamlc -custom), require
 the Cygwin development tools, available at
         http://www.cygwin.com/
 and the flexdll tool, available at
         http://alain.frisch.fr/flexdll.html
 You will need to install at least the following Cygwin packages (use
 the Setup tool from Cygwin):
-binutils, gcc-core, gcc-mingw-core, mingw-runtime, w32api.
 
-Do *not* install the Mingw/MSYS development tools from www.mingw.org:
-these are not compatible with this Caml port (@responsefile not
-recognized on the command line).
+ mingw64-i686-binutils
+ mingw64-i686-gcc
+ mingw64-i686-runtime
+
+
+NOTE:
+  - There is another 32-bit gcc compiler, from the MinGW.org
+    project, packaged in Cygwin under the name mingw-gcc.
+    It is not currently supported by flexdll and OCaml.
+
+  - The standard gcc compiler shipped with Cygwin used to
+    support a "-mno-cygwin" option, which turned the compiler
+    into a mingw compiler. This option was used
+    by previous versions of flexdll and OCaml, but it is no
+    longer available in recent version, hence the switch
+    to another toolchain packaged in Cygwin.
+
+  - The standalone mingw toolchain from the MinGW-w64 project
+    (http://mingw-w64.sourceforge.net/) is not supported.
+    Please use the version packaged in Cygwin instead.
 
 The LablTk GUI requires Tcl/Tk 8.5.  Windows binaries are available
 as part of the ActiveTCL distribution at
@@ -235,14 +248,19 @@ RECOMPILATION FROM THE SOURCES:
 You will need the following software components to perform the recompilation:
 - Windows NT, 2000, XP, or Vista.
 - Cygwin: http://sourceware.cygnus.com/cygwin/
-  Install at least the following packages: binutils, diffutils,
-    gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32api.
+  Install at least the following packages:
+     mingw64-i686-binutils
+     mingw64-i686-gcc
+     mingw64-i686-runtime
+     diffutils
+     make
+     ncurses
 - TCL/TK version 8.5 (see above).
 - The flexdll tool (see above).
 
-Do *not* install the standalone distribution of MinGW, nor the
-companion MSYS tools: these have problems with long command lines.
-Instead, use the version of MinGW provided by Cygwin.
+The standalone mingw toolchain from the MinGW-w64 project
+(http://mingw-w64.sourceforge.net/) is not supported.  Please use the
+version packaged in Cygwin instead.
 
 Start a Cygwin shell and unpack the source distribution
 (ocaml-X.YY.Z.tar.gz) with "tar xzf".  Change to the top-level
@@ -275,8 +293,8 @@ NOTES:
 
 ------------------------------------------------------------------------------
 
-                  The Cygwin port of Objective Caml
-                  ---------------------------------
+                  The Cygwin port of OCaml
+                  ------------------------
 
 REQUIREMENTS:
 
@@ -323,7 +341,7 @@ Windows 7 64 on Intel64/AMD64 machines.
 The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...)
 runs without any additional tools.
 
-Statically linking Caml bytecode with C code (ocamlc -custom) requires the
+Statically linking OCaml bytecode with C code (ocamlc -custom) requires the
 Microsoft Platform SDK compiler (item [1] in the section
 "third-party software" below) and the flexdll tool (item [2]).
 
@@ -345,7 +363,7 @@ THIRD-PARTY SOFTWARE:
     http://www.microsoft.com/downloads/en/default.aspx
     under the name "Microsoft Windows 7 SDK".
 
-[2] flexdll version 0.23 or later.
+[2] flexdll version 0.29 or later.
     Can be downloaded from http://alain.frisch.fr/flexdll.html
 
 

diff --git a/VERSION b/VERSION
index e34a5e1e23a3ea1e1ad306959ddc38d2d4e08896..c3a421f747c8ce0c016ccd6b8542337ea4fcbb05 100644 (file)
--- a/VERSION
+++ b/VERSION
@@ -1,4 +1,4 @@
-3.12.1
+4.00.0+dev15_2012-04-16
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

diff --git a/_tags b/_tags
index 052d8aee1956c277def3e18c403219de646b9418..82c7c649e8e9ca768fd43b721f83d4357fc7da49 100644 (file)
--- a/_tags
+++ b/_tags
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # Ocamlbuild tags file
 
 true: -traverse

diff --git a/asmcomp/.cvsignore b/asmcomp/.cvsignore
deleted file mode 100644 (file)
index 31d0017..0000000
--- a/asmcomp/.cvsignore
+++ /dev/null
@@ -1,6 +0,0 @@
-emit.ml
-arch.ml
-proc.ml
-selection.ml
-reload.ml
-scheduling.ml

diff --git a/asmcomp/.ignore b/asmcomp/.ignore
new file mode 100644 (file)
index 0000000..31d0017
--- /dev/null
+++ b/asmcomp/.ignore
@@ -0,0 +1,6 @@
+emit.ml
+arch.ml
+proc.ml
+selection.ml
+reload.ml
+scheduling.ml

diff --git a/asmcomp/alpha/arch.ml b/asmcomp/alpha/arch.ml
deleted file mode 100644 (file)
index 52d1f11..0000000
--- a/asmcomp/alpha/arch.ml
+++ /dev/null
@@ -1,83 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Specific operations for the Alpha processor *)
-
-open Misc
-open Format
-
-(* Machine-specific command-line options *)
-
-let command_line_options = []
-
-(* Addressing modes *)
-
-type addressing_mode =
-    Ibased of string * int              (* symbol + displ *)
-  | Iindexed of int                     (* reg + displ *)
-
-(* Specific operations *)
-
-type specific_operation =
-    Iadd4 | Iadd8 | Isub4 | Isub8       (* Scaled adds and subs *)
-  | Ireloadgp of bool                   (* The ldgp instruction *)
-  | Itrunc32                            (* Truncate 64-bit int to 32 bit *)
-
-(* Sizes, endianness *)
-
-let big_endian = false
-
-let size_addr = 8
-let size_int = 8
-let size_float = 8
-
-(* Operations on addressing modes *)
-
-let identity_addressing = Iindexed 0
-
-let offset_addressing addr delta =
-  match addr with
-    Ibased(s, n) -> Ibased(s, n + delta)
-  | Iindexed n -> Iindexed(n + delta)
-
-let num_args_addressing = function
-    Ibased(s, n) -> 0
-  | Iindexed n -> 1
-
-(* Printing operations and addressing modes *)
-
-let print_addressing printreg addr ppf arg =
-  match addr with
-  | Ibased(s, n) ->
-      fprintf ppf "\"%s\"%s" s
-      (if n <> 0 then Printf.sprintf " + %i" n else "")
-  | Iindexed n ->
-      fprintf ppf "%a%s" printreg arg.(0)
-      (if n <> 0 then Printf.sprintf " + %i" n else "")
-
-let print_specific_operation printreg op ppf arg =
-  match op with
-  | Iadd4 -> fprintf ppf "%a  * 4 + %a" printreg arg.(0) printreg arg.(1)
-  | Iadd8 -> fprintf ppf "%a  * 8 + %a" printreg arg.(0) printreg arg.(1)
-  | Isub4 -> fprintf ppf "%a  * 4 - %a" printreg arg.(0) printreg arg.(1)
-  | Isub8 -> fprintf ppf "%a  * 8 - %a" printreg arg.(0) printreg arg.(1)
-  | Ireloadgp _ -> fprintf ppf "ldgp"
-  | Itrunc32 -> fprintf ppf "truncate32 %a" printreg arg.(0)
-
-(* Distinguish between the Digital assembler and other assemblers (e.g. gas) *)
-
-let digital_asm =
-  match Config.system with
-    "digital" -> true
-  | _ -> false

diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp
deleted file mode 100644 (file)
index 6857da0..0000000
--- a/asmcomp/alpha/emit.mlp
+++ /dev/null
@@ -1,861 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-module LabelSet =
-  Set.Make(struct type t = Linearize.label let compare = compare end)
-
-(* Emission of Alpha assembly code *)
-
-open Location
-open Misc
-open Cmm
-open Arch
-open Proc
-open Reg
-open Mach
-open Linearize
-open Emitaux
-
-(* First pass: insert Iloadgp instructions where needed *)
-
-let insert_load_gp f =
-
-  let labels_needing_gp = ref LabelSet.empty in
-  let fixpoint_reached = ref false in
-
-  let label_needs_gp lbl =
-    LabelSet.mem lbl !labels_needing_gp in
-  let opt_label_needs_gp default = function
-      None -> default
-    | Some lbl -> label_needs_gp lbl in
-  let set_label_needs_gp lbl =
-    if not (label_needs_gp lbl) then begin
-      fixpoint_reached := false;
-      labels_needing_gp := LabelSet.add lbl !labels_needing_gp
-    end in
-
-  let tailrec_entry_point = new_label() in
-
-  (* Determine if $gp is needed before an instruction.
-     [next] says whether $gp is needed just after (i.e. by the following
-     instruction). *)
-  let instr_needs_gp next = function
-      Lend -> false
-    | Lop(Iconst_int n) ->         (* for large n, turned into ldq ($gp) *)
-        next || n < Nativeint.of_int(-0x80000000)
-             || n > Nativeint.of_int 0x7FFFFFFF
-    | Lop(Iconst_float s) -> true       (* turned into ldq ($gp) *)
-    | Lop(Iconst_symbol s) -> true      (* turned into ldq ($gp) *)
-    | Lop(Icall_ind) -> false           (* does ldgp if needed afterwards *)
-    | Lop(Icall_imm s) -> true          (* does lda $27, <s> *)
-    | Lop(Itailcall_ind) -> false
-    | Lop(Itailcall_imm s) ->
-        if s = f.fun_name then label_needs_gp tailrec_entry_point else true
-    | Lop(Iextcall(_, _)) -> true       (* does lda $27, <s> *)
-    | Lop(Iload(_, Ibased(_, _))) -> true (* loads address from ($gp) *)
-    | Lop(Istore(_, Ibased(_, _))) -> true (* loads address from ($gp) *)
-    | Lop(Iintop(Idiv | Imod)) -> true  (* divq and remq can be turned into *)
-    | Lop(Iintop_imm((Idiv | Imod), _)) -> true (* a function call *)
-    | Lop(Iintop_imm(_, n)) ->     (* for large n, turned into ldq ($gp) *)
-        next || n < -0x80000000 || n > 0x7FFFFFFF
-    | Lop _ -> next
-    | Lreloadretaddr -> next
-    | Lreturn -> false
-    | Llabel lbl -> if next then set_label_needs_gp lbl; next
-    | Lbranch lbl -> label_needs_gp lbl
-    | Lcondbranch(tst, lbl) -> next || label_needs_gp lbl
-    | Lcondbranch3(lbl1, lbl2, lbl3) ->
-        opt_label_needs_gp next lbl1 ||
-        opt_label_needs_gp next lbl2 ||
-        opt_label_needs_gp next lbl3
-    | Lswitch lblv -> true
-    | Lsetuptrap lbl -> label_needs_gp lbl
-    | Lpushtrap -> next
-    | Lpoptrap -> next
-    | Lraise -> false in
-
-  let rec needs_gp i =
-    if i.desc = Lend
-    then false
-    else instr_needs_gp (needs_gp i.next) i.desc in
-
-  while not !fixpoint_reached do
-    fixpoint_reached := true;
-    if needs_gp f.fun_body then set_label_needs_gp tailrec_entry_point
-  done;
-
-  (* Insert Ireloadgp instructions after calls where needed *)
-  let rec insert_reload_gp i =
-    if i.desc = Lend then (i, false) else begin
-      let (new_next, needs_next) = insert_reload_gp i.next in
-      let new_instr =
-        match i.desc with
-          (* If the instruction destroys $gp and $gp is needed afterwards,
-             insert a ldgp after the instructions. *)
-          Lop(Icall_ind | Icall_imm _) when needs_next ->
-            {i with next =
-              instr_cons (Lop(Ispecific(Ireloadgp true))) [||] [||] new_next }
-        | Lop(Iextcall(_, false)) | Lsetuptrap _ when needs_next ->
-            {i with next =
-              instr_cons (Lop(Ispecific(Ireloadgp false))) [||] [||] new_next }
-        | _ ->
-            {i with next = new_next} in
-      (new_instr, instr_needs_gp needs_next i.desc)
-    end in
-
-  let (new_body, uses_gp) = insert_reload_gp f.fun_body in
-  ({f with fun_body = new_body}, uses_gp)
-
-(* Second pass: code generation proper *)
-
-(* Tradeoff between code size and code speed *)
-
-let fastcode_flag = ref true
-
-(* Output a label *)
-
-let emit_label lbl =
-  emit_string "$"; emit_int lbl
-
-let emit_Llabel fallthrough lbl =
-  if (not fallthrough) then begin
-    emit_string "      .align  4\n"
-  end ;
-  emit_label lbl
-
-(* Output a symbol *)
-
-let emit_symbol s =
-  Emitaux.emit_symbol '$' s
-
-(* Output a pseudo-register *)
-
-let emit_reg r =
-  match r.loc with
-    Reg r -> emit_string (register_name r)
-  | _ -> fatal_error "Emit_alpha.emit_reg"
-
-(* Layout of the stack frame *)
-
-let stack_offset = ref 0
-
-let frame_size () =
-  let size =
-    !stack_offset +
-    8 * (num_stack_slots.(0) + num_stack_slots.(1)) +
-    (if !contains_calls then 8 else 0) in
-  Misc.align size 16
-
-let slot_offset loc cl =
-  match loc with
-    Incoming n -> frame_size() + n
-  | Local n ->
-      if cl = 0
-      then !stack_offset + n * 8
-      else !stack_offset + (num_stack_slots.(0) + n) * 8
-  | Outgoing n -> n
-
-(* Output a stack reference *)
-
-let emit_stack r =
-  match r.loc with
-    Stack s ->
-      let ofs = slot_offset s (register_class r) in `{emit_int ofs}($sp)`
-  | _ -> fatal_error "Emit_alpha.emit_stack"
-
-(* Output an addressing mode *)
-
-let emit_addressing addr r n =
-  match addr with
-    Iindexed ofs ->
-      `{emit_int ofs}({emit_reg r.(n)})`
-  | Ibased(s, ofs) ->
-      `{emit_symbol s}`;
-      if ofs > 0 then ` + {emit_int ofs}`;
-      if ofs < 0 then ` - {emit_int(-ofs)}`
-
-(* Immediate operands *)
-
-let is_immediate n = digital_asm || (n >= 0 && n <= 255)
-
-(* Communicate live registers at call points to the assembler *)
-
-let int_reg_number = [|
-  0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12;
-  16; 17; 18; 19; 20; 21; 22
-|]
-
-let float_reg_number = [|
-  0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15;
-  16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 29; 30
-|]
-
-let liveregs instr extra_msk =
-  (* $13, $14, $15 always live *)
-  let int_mask = ref(0x00070000 lor extra_msk)
-  and float_mask = ref 0 in
-  let add_register = function
-      {loc = Reg r; typ = (Int | Addr)} ->
-        int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r)))
-    | {loc = Reg r; typ = Float} ->
-        float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100)))
-    | _ -> () in
-  Reg.Set.iter add_register instr.live;
-  Array.iter add_register instr.arg;
-  emit_printf "        .livereg 0x%08x, 0x%08x\n" !int_mask !float_mask
-
-let live_24 = 1 lsl (31 - 24)
-let live_25 = 1 lsl (31 - 25)
-let live_26 = 1 lsl (31 - 26)
-let live_27 = 1 lsl (31 - 27)
-
-(* Record live pointers at call points *)
-
-type frame_descr =
-  { fd_lbl: int;                        (* Return address *)
-    fd_frame_size: int;                 (* Size of stack frame *)
-    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
-
-let frame_descriptors = ref([] : frame_descr list)
-
-let record_frame_label live =
-  let lbl = new_label() in
-  let live_offset = ref [] in
-  Reg.Set.iter
-    (function
-        {typ = Addr; loc = Reg r} ->
-          live_offset := ((int_reg_number.(r) lsl 1) + 1) :: !live_offset
-      | {typ = Addr; loc = Stack s} as reg ->
-          live_offset := slot_offset s (register_class reg) :: !live_offset
-      | _ -> ())
-    live;
-  frame_descriptors :=
-    { fd_lbl = lbl;
-      fd_frame_size = frame_size();
-      fd_live_offset = !live_offset } :: !frame_descriptors;
-  lbl
-
-let record_frame live =
-  let lbl = record_frame_label live in `{emit_label lbl}:`
-
-let emit_frame fd =
-  `    .quad   {emit_label fd.fd_lbl}\n`;
-  `    .word   {emit_int fd.fd_frame_size}\n`;
-  `    .word   {emit_int (List.length fd.fd_live_offset)}\n`;
-  List.iter
-    (fun n ->
-      `        .word   {emit_int n}\n`)
-    fd.fd_live_offset;
-  `    .align  3\n`
-
-(* Record calls to the GC -- we've moved them out of the way *)
-
-type gc_call =
-  { gc_lbl: label;                      (* Entry label *)
-    gc_return_lbl: label;               (* Where to branch after GC *)
-    gc_frame: label;                    (* Label of frame descriptor *)
-    gc_instr: instruction }             (* Record live registers *)
-
-let call_gc_sites = ref ([] : gc_call list)
-
-let emit_call_gc gc =
-  `{emit_label gc.gc_lbl}:`;
-  liveregs gc.gc_instr 0;
-  `    bsr     $26, caml_call_gc\n`;
-  (* caml_call_gc preserves $gp *)
-  `{emit_label gc.gc_frame}:   br      {emit_label gc.gc_return_lbl}\n`
-
-(* Name of readonly data section *)
-
-let rdata_section =
-  match Config.system with
-    "digital" -> ".rdata"
-  | "linux" | "openbsd" | "netbsd" | "freebsd" | "gnu" -> ".section .rodata"
-  | _ -> assert false
-
-(* Names of various instructions *)
-
-let name_for_int_operation = function
-    Iadd -> "addq"
-  | Isub -> "subq"
-  | Imul -> "mulq"
-  | Idiv -> "divq"
-  | Imod -> "remq"
-  | Iand -> "and"
-  | Ior -> "or"
-  | Ixor -> "xor"
-  | Ilsl -> "sll"
-  | Ilsr -> "srl"
-  | Iasr -> "sra"
-  | _ -> Misc.fatal_error "Emit.name_for_int_operation"
-
-let name_for_float_operation = function
-    Inegf -> "fneg"
-  | Iabsf -> "fabs"
-  | Iaddf -> "addt"
-  | Isubf -> "subt"
-  | Imulf -> "mult"
-  | Idivf -> "divt"
-  | _ -> Misc.fatal_error "Emit.name_for_float_operation"
-
-let name_for_specific_operation = function
-    Iadd4 -> "s4addq"
-  | Iadd8 -> "s8addq"
-  | Isub4 -> "s4subq"
-  | Isub8 -> "s8subq"
-  | _ -> Misc.fatal_error "Emit.name_for_specific_operation"
-
-let name_for_int_comparison = function
-    Isigned Ceq -> "cmpeq", true     | Isigned Cne -> "cmpeq", false
-  | Isigned Cle -> "cmple", true     | Isigned Cgt -> "cmple", false
-  | Isigned Clt -> "cmplt", true     | Isigned Cge -> "cmplt", false
-  | Iunsigned Ceq -> "cmpeq", true   | Iunsigned Cne -> "cmpeq", false
-  | Iunsigned Cle -> "cmpule", true  | Iunsigned Cgt -> "cmpule", false
-  | Iunsigned Clt -> "cmpult", true  | Iunsigned Cge -> "cmpult", false
-
-(* Used for comparisons against 0 *)
-let name_for_int_cond_branch = function
-    Isigned Ceq -> "beq"     | Isigned Cne -> "bne"
-  | Isigned Cle -> "ble"     | Isigned Cgt -> "bgt"
-  | Isigned Clt -> "blt"     | Isigned Cge -> "bge"
-  | Iunsigned Ceq -> "beq"   | Iunsigned Cne -> "bne"
-  | Iunsigned Cle -> "beq"   | Iunsigned Cgt -> "bne"
-  | Iunsigned Clt -> "#"     | Iunsigned Cge -> "br"
-    (* Always false *)         (* Always true *)
-
-let name_for_float_comparison cmp neg =
-  match cmp with
-    Ceq -> ("cmpteq", false, neg)  | Cne -> ("cmpteq", false, not neg)
-  | Cle -> ("cmptle", false, neg)  | Cgt -> ("cmptlt", true, neg)
-  | Clt -> ("cmptlt", false, neg)  | Cge -> ("cmptle", true, neg)
-
-(* Output the assembly code for an instruction *)
-
-(* Name of current function *)
-let function_name = ref ""
-(* Entry point for tail recursive calls *)
-let tailrec_entry_point = ref 0
-(* Label of trap for out-of-range accesses *)
-let range_check_trap = ref 0
-(* List of floating-point and big integer literals
-   (fon non-Digital assemblers) *)
-let float_constants = ref ([] : (label * string) list)
-let bigint_constants = ref ([] : (label * nativeint) list)
-
-let emit_instr fallthrough i =
-    match i.desc with
-      Lend -> ()
-    | Lop(Imove | Ispill | Ireload) ->
-        let src = i.arg.(0) and dst = i.res.(0) in
-        if src.loc <> dst.loc then begin
-          match (src.loc, dst.loc) with
-            (Reg rs, Reg rd) ->
-              if src.typ = Float then
-                `      fmov    {emit_reg src}, {emit_reg dst}\n`
-              else
-                `      mov     {emit_reg src}, {emit_reg dst}\n`
-          | (Reg rs, Stack sd) ->
-              if src.typ = Float then
-                `      stt     {emit_reg src}, {emit_stack dst}\n`
-              else
-                `      stq     {emit_reg src}, {emit_stack dst}\n`
-          | (Stack ss, Reg rd) ->
-              if src.typ = Float then
-                `      ldt     {emit_reg dst}, {emit_stack src}\n`
-              else
-                `      ldq     {emit_reg dst}, {emit_stack src}\n`
-          | _ ->
-              fatal_error "Emit_alpha: Imove"
-        end
-    | Lop(Iconst_int n) ->
-        if n = 0n then
-          `    clr     {emit_reg i.res.(0)}\n`
-        else if digital_asm ||
-                (n >= Nativeint.of_int (-0x80000000) &&
-                 n <= Nativeint.of_int 0x7FFFFFFF) then
-          `    ldiq    {emit_reg i.res.(0)}, {emit_nativeint n}\n`
-        else begin
-          (* Work around a bug in gas/gld concerning big integer constants *)
-          let lbl = new_label() in
-          bigint_constants := (lbl, n) :: !bigint_constants;
-          `    lda     $25, {emit_label lbl}\n`;
-          `    ldq     {emit_reg i.res.(0)}, 0($25)\n`
-        end
-    | Lop(Iconst_float s) ->
-        if digital_asm then
-          `    ldit    {emit_reg i.res.(0)}, {emit_string s}\n`
-        else if Int64.bits_of_float (float_of_string s) = 0L then
-          `    fmov    $f31, {emit_reg i.res.(0)}\n`
-        else begin
-          let lbl = new_label() in
-          float_constants := (lbl, s) :: !float_constants;
-          `    lda     $25, {emit_label lbl}\n`;
-          `    ldt     {emit_reg i.res.(0)}, 0($25)\n`
-        end
-    | Lop(Iconst_symbol s) ->
-        `      lda     {emit_reg i.res.(0)}, {emit_symbol s}\n`
-    | Lop(Icall_ind) ->
-        liveregs i 0;
-        `      mov     {emit_reg i.arg.(0)}, $27\n`;
-        `      jsr     ({emit_reg i.arg.(0)})\n`;
-        `{record_frame i.live}\n`
-    | Lop(Icall_imm s) ->
-        liveregs i 0;
-        `      jsr     {emit_symbol s}\n`;
-        `{record_frame i.live}\n`
-    | Lop(Itailcall_ind) ->
-        let n = frame_size() in
-        if !contains_calls then
-          `    ldq     $26, {emit_int(n - 8)}($sp)\n`;
-        if n > 0 then
-          `    lda     $sp, {emit_int n}($sp)\n`;
-        `      mov     {emit_reg i.arg.(0)}, $27\n`;
-        liveregs i (live_26 + live_27);
-        `      jmp     ({emit_reg i.arg.(0)})\n`
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name then begin
-          `    br      {emit_label !tailrec_entry_point}\n`
-        end else begin
-          let n = frame_size() in
-          if !contains_calls then
-            `  ldq     $26, {emit_int(n - 8)}($sp)\n`;
-          if n > 0 then
-            `  lda     $sp, {emit_int n}($sp)\n`;
-          `    lda     $27, {emit_symbol s}\n`;
-          liveregs i (live_26 + live_27);
-          `    br      {emit_symbol s}\n`
-        end
-    | Lop(Iextcall(s, alloc)) ->
-        if alloc then begin
-          `    lda     $25, {emit_symbol s}\n`;
-          liveregs i live_25;
-          `    bsr     $26, caml_c_call\n`;
-          `{record_frame i.live}\n`
-        end else begin
-          `    jsr     {emit_symbol s}\n`
-        end
-    | Lop(Istackoffset n) ->
-        `      lda     $sp, {emit_int (-n)}($sp)\n`;
-        stack_offset := !stack_offset + n
-    | Lop(Iload(chunk, addr)) ->
-        let dest = i.res.(0) in
-        let load_instr =
-          match chunk with
-          | Byte_unsigned -> "ldbu"
-          | Byte_signed -> "ldb"
-          | Sixteen_unsigned -> "ldwu"
-          | Sixteen_signed -> "ldw"
-          | Thirtytwo_unsigned -> "ldl"
-          | Thirtytwo_signed -> "ldl"
-          | Word -> "ldq"
-          | Single -> "lds"
-          | Double -> "ldt"
-          | Double_u -> "ldt" in
-        `      {emit_string load_instr}        {emit_reg dest}, {emit_addressing addr i.arg 0}\n`;
-        if chunk = Thirtytwo_unsigned then
-          `    zapnot  {emit_reg dest}, 15, {emit_reg dest}\n`
-    | Lop(Istore(chunk, addr)) ->
-        let store_instr =
-          match chunk with
-          | Byte_unsigned | Byte_signed -> "stb"
-          | Sixteen_unsigned | Sixteen_signed -> "stw"
-          | Thirtytwo_unsigned | Thirtytwo_signed -> "stl"
-          | Word -> "stq"
-          | Single -> "sts"
-          | Double -> "stt"
-          | Double_u -> "stt" in
-        `      {emit_string store_instr}       {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
-    | Lop(Ialloc n) ->
-        if !fastcode_flag then begin
-          let lbl_redo = new_label() in
-          let lbl_call_gc = new_label() in
-          let lbl_frame = record_frame_label i.live in
-          call_gc_sites :=
-            { gc_lbl = lbl_call_gc;
-              gc_return_lbl = lbl_redo;
-              gc_frame = lbl_frame;
-              gc_instr = i } :: !call_gc_sites;
-          `{emit_label lbl_redo}:      lda     $13, -{emit_int n}($13)\n`;
-          `    cmpult  $13, $14, $25\n`;
-          `    bne     $25, {emit_label lbl_call_gc}\n`;
-          `    addq    $13, 8, {emit_reg i.res.(0)}\n`
-        end else begin
-          begin match n with
-            16 -> liveregs i 0;
-                  `    bsr     $26, caml_alloc1\n`
-          | 24 -> liveregs i 0;
-                  `    bsr     $26, caml_alloc2\n`
-          | 32 -> liveregs i 0;
-                  `    bsr     $26, caml_alloc3\n`
-          | _  -> `    ldiq    $25, {emit_int n}\n`;
-                  liveregs i live_25;
-                  `    bsr     $26, caml_allocN\n`
-          end;
-          (* $gp preserved by caml_alloc* *)
-          `{record_frame i.live}       addq    $13, 8, {emit_reg i.res.(0)}\n`
-        end
-    | Lop(Iintop(Icomp cmp)) ->
-        let (comp, test) = name_for_int_comparison cmp in
-        `      {emit_string comp}      {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`;
-        if not test then
-          `    xor     {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop(Icheckbound)) ->
-        if !range_check_trap = 0 then range_check_trap := new_label();
-        `      cmpule  {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`;
-        `      bne     $25, {emit_label !range_check_trap}\n`
-    | Lop(Iintop op) ->
-        let instr = name_for_int_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Idiv, n)) ->
-        if n = 1 lsl (Misc.log2 n) then begin
-          let l = Misc.log2 n in
-          if is_immediate n then
-            `  addq    {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n`
-          else begin
-            `  ldiq    $25, {emit_int(n-1)}\n`;
-            `  addq    {emit_reg i.arg.(0)}, $25, $25\n`
-          end;
-          `    cmovge  {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, $25\n`;
-          `    sra     $25, {emit_int l}, {emit_reg i.res.(0)}\n`
-        end else begin
-          (* divq with immediate arg is incorrectly assembled in Tru64 5.1,
-             so emulate it ourselves *)
-          `    ldiq    $25, {emit_int n}\n`;
-          `    divq    {emit_reg i.arg.(0)}, $25, {emit_reg i.res.(0)}\n`
-        end
-    | Lop(Iintop_imm(Imod, n)) ->
-        if n = 1 lsl (Misc.log2 n) then begin
-          if is_immediate n then
-            `  and     {emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n`
-          else begin
-            `  ldiq    $25, {emit_int (n-1)}\n`;
-            `  and     {emit_reg i.arg.(0)}, $25, $25\n`
-          end;
-          `    subq    $25, {emit_int n}, $24\n`;
-          `    cmovge  {emit_reg i.arg.(0)}, $25, $24\n`;
-          `    cmoveq  $25, $25, $24\n`;
-          `    mov     $24, {emit_reg i.res.(0)}\n`
-        end else begin
-          (* remq with immediate arg is incorrectly assembled in Tru64 5.1,
-             so emulate it ourselves *)
-          `    ldiq    $25, {emit_int n}\n`;
-          `    remq    {emit_reg i.arg.(0)}, $25, {emit_reg i.res.(0)}\n`
-        end
-    | Lop(Iintop_imm(Ilsl, 1)) ->
-        (* Turn x << 1 into x + x, slightly faster according to the docs *)
-        `      addq    {emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Icomp cmp, n)) ->
-        let (comp, test) = name_for_int_comparison cmp in
-        `      {emit_string comp}      {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`;
-        if not test then
-          `    xor     {emit_reg i.res.(0)}, 1, {emit_reg i.res.(0)}\n`
-
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-        if !range_check_trap = 0 then range_check_trap := new_label();
-        `      cmpule  {emit_reg i.arg.(0)}, {emit_int n}, $25\n`;
-        `      bne     $25, {emit_label !range_check_trap}\n`
-    | Lop(Iintop_imm(op, n)) ->
-        let instr = name_for_int_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_int n}, {emit_reg i.res.(0)}\n`
-    | Lop(Inegf | Iabsf as op) ->
-        let instr = name_for_float_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
-        let instr = name_for_float_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lop(Ifloatofint) ->
-        `      .set    noat\n`;
-        `      lda     $sp, -8($sp)\n`;
-        `      stq     {emit_reg i.arg.(0)}, 0($sp)\n`;
-        `      ldt     $f28, 0($sp)\n`;
-        `      cvtqt   $f28, {emit_reg i.res.(0)}\n`;
-        `      lda     $sp, 8($sp)\n`;
-        `      .set    at\n`
-    | Lop(Iintoffloat) ->
-        `      .set    noat\n`;
-        `      lda     $sp, -8($sp)\n`;
-        `      cvttqc  {emit_reg i.arg.(0)}, $f28\n`;
-        `      stt     $f28, 0($sp)\n`;
-        `      ldq     {emit_reg i.res.(0)}, 0($sp)\n`;
-        `      lda     $sp, 8($sp)\n`;
-        `      .set    at\n`
-    | Lop(Ispecific(Ireloadgp marked_r26)) ->
-        `      ldgp    $gp, 0($26)\n`;
-        if marked_r26 then
-          `    bic     $gp, 1, $gp\n`
-    | Lop(Ispecific Itrunc32) ->
-        `      addl    {emit_reg i.arg.(0)}, 0, {emit_reg i.res.(0)}\n`
-    | Lop(Ispecific sop) ->
-        let instr = name_for_specific_operation sop in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lreloadretaddr ->
-        let n = frame_size() in
-        `      ldq     $26, {emit_int(n - 8)}($sp)\n`
-    | Lreturn ->
-        let n = frame_size() in
-        if n > 0 then
-          `    lda     $sp, {emit_int n}($sp)\n`;
-        liveregs i live_26;
-        `      ret     ($26)\n`
-    | Llabel lbl ->
-        `{emit_Llabel fallthrough lbl}:\n`
-    | Lbranch lbl ->
-        `      br      {emit_label lbl}\n`
-    | Lcondbranch(tst, lbl) ->
-        begin match tst with
-          Itruetest ->
-            `  bne     {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-        | Ifalsetest ->
-            `  beq     {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-        | Iinttest cmp ->
-            let (comp, test) = name_for_int_comparison cmp in
-            `  {emit_string comp}      {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $25\n`;
-            if test then
-              `        bne     $25, {emit_label lbl}\n`
-            else
-              `        beq     $25, {emit_label lbl}\n`
-        | Iinttest_imm(cmp, 0) ->
-            let branch = name_for_int_cond_branch cmp in
-            `  {emit_string branch}    {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-        | Iinttest_imm(cmp, n) ->
-            let (comp, test) = name_for_int_comparison cmp in
-            `  {emit_string comp}      {emit_reg i.arg.(0)}, {emit_int n}, $25\n`;
-            if test then
-              `        bne     $25, {emit_label lbl}\n`
-            else
-              `        beq     $25, {emit_label lbl}\n`
-        | Ifloattest(cmp, neg) ->
-            `  .set    noat\n`;
-            let (comp, swap, test) = name_for_float_comparison cmp neg in
-            `  {emit_string comp}      `;
-            if swap
-            then `{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, $f28\n`
-            else `{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $f28\n`;
-            if test
-            then `     fbeq    $f28, {emit_label lbl}\n`
-            else `     fbne    $f28, {emit_label lbl}\n`;
-            `  .set    at\n`
-        | Ioddtest ->
-            `  blbs    {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-        | Ieventest ->
-            `  blbc    {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-        end
-    | Lcondbranch3(lbl0, lbl1, lbl2) ->
-        begin match lbl0 with
-          None -> ()
-        | Some lbl -> `        beq     {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-        end;
-        begin match lbl1 with
-          None -> ()
-        | Some lbl -> `        blbs    {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-        end;
-        begin match lbl2 with
-          None -> ()
-        | Some lbl ->
-            if lbl0 <> None then
-              `        blbc    {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-            else if lbl1 <> None then
-              `        bne     {emit_reg i.arg.(0)}, {emit_label lbl}\n`
-            else begin
-              `        subq    {emit_reg i.arg.(0)}, 2, $25\n`;
-              `        beq     $25, {emit_label lbl}\n`
-            end
-        end
-    | Lswitch jumptbl ->
-        let lbl_jumptbl = new_label() in
-        `      lda     $25, {emit_label lbl_jumptbl}\n`;
-        `      s4addq  {emit_reg i.arg.(0)}, $25, $25\n`;
-        `      ldl     $25, 0($25)\n`;
-        `      addq    $gp, $25, $25\n`;
-        `      jmp     ($25), {emit_label jumptbl.(0)}\n`;
-        `      {emit_string rdata_section}\n`;
-        `{emit_label lbl_jumptbl}:`;
-        for i = 0 to Array.length jumptbl - 1 do
-          `    .gprel32 {emit_label jumptbl.(i)}\n`
-        done;
-        `      .text\n`
-    | Lsetuptrap lbl ->
-        `      br      $25, {emit_label lbl}\n`
-    | Lpushtrap ->
-        stack_offset := !stack_offset + 16;
-        `      lda     $sp, -16($sp)\n`;
-        `      stq     $15, 0($sp)\n`;
-        `      stq     $25, 8($sp)\n`;
-        `      mov     $sp, $15\n`
-    | Lpoptrap ->
-        `      ldq     $15, 0($sp)\n`;
-        `      lda     $sp, 16($sp)\n`;
-        stack_offset := !stack_offset - 16
-    | Lraise ->
-        `      ldq     $26, 8($15)\n`;
-        `      mov     $15, $sp\n`;
-        `      ldq     $15, 0($sp)\n`;
-        `      lda     $sp, 16($sp)\n`;
-        liveregs i live_26;
-        `      jmp     $25, ($26)\n`   (* Keep retaddr in $25 for debugging *)
-
-let rec emit_all fallthrough i =  match i.desc with
-| Lend -> ()
-| _ ->
-    emit_instr fallthrough i;
-    emit_all (has_fallthrough i.desc) i.next
-
-(* Emission of a function declaration *)
-
-let emit_fundecl (fundecl, needs_gp) =
-  function_name := fundecl.fun_name;
-  fastcode_flag := fundecl.fun_fast;
-  stack_offset := 0;
-  call_gc_sites := [];
-  range_check_trap := 0;
-  float_constants := [];
-  bigint_constants := [];
-  `    .text\n`;
-  `    .align  4\n`;
-  `    .globl  {emit_symbol fundecl.fun_name}\n`;
-  `    .ent    {emit_symbol fundecl.fun_name}\n`;
-  `{emit_symbol fundecl.fun_name}:\n`;
-  if needs_gp then begin
-    `  .set    noreorder\n`;
-    `  ldgp    $gp, 0($27)\n`;
-    `  .set    reorder\n`
-  end;
-  let n = frame_size() in
-  if n > 0 then
-    `  lda     $sp, -{emit_int n}($sp)\n`;
-  if !contains_calls then begin
-    `  stq     $26, {emit_int(n - 8)}($sp)\n`;
-    `  .mask   0x04000000, -8\n`;
-    `  .fmask  0x0, 0\n`
-  end;
-  `    .frame  $sp, {emit_int n}, $26\n`;
-  `    .prologue {emit_int(if needs_gp then 1 else 0)}\n`;
-  tailrec_entry_point := new_label();
-  `{emit_label !tailrec_entry_point}:\n`;
-  emit_all true fundecl.fun_body;
-  List.iter emit_call_gc !call_gc_sites;
-  if !range_check_trap > 0 then begin
-    `{emit_label !range_check_trap}:\n`;
-    `  br      $26, caml_ml_array_bound_error\n`
-    (* Keep retaddr in $26 for debugging *)
-  end;
-  `    .end    {emit_symbol fundecl.fun_name}\n`;
-  if !bigint_constants <> [] then begin
-    `  {emit_string rdata_section}\n`;
-    `  .align  3\n`;
-    List.iter
-      (fun (lbl, n) -> `{emit_label lbl}:      .quad   0x{emit_string(Nativeint.format "%x" n)}\n`)
-      !bigint_constants
-  end;
-  if !float_constants <> [] then begin
-    `  {emit_string rdata_section}\n`;
-    `  .align  3\n`;
-    List.iter
-      (fun (lbl, s) -> `{emit_label lbl}:      .t_floating {emit_string s}\n`)
-      !float_constants
-  end
-
-let fundecl f =
-  emit_fundecl (insert_load_gp f)
-
-(* Emission of data *)
-
-let emit_item = function
-    Cglobal_symbol s ->
-      `        .globl  {emit_symbol s}\n`;
-  | Cdefine_symbol s ->
-      `{emit_symbol s}:\n`
-  | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)}:\n`
-  | Cint8 n ->
-      `        .byte   {emit_int n}\n`
-  | Cint16 n ->
-      `        .word   {emit_int n}\n`
-  | Cint32 n ->
-      let n' = Nativeint.shift_right (Nativeint.shift_left n 32) 32 in
-      `        .long   {emit_nativeint n'}\n`
-  | Cint n ->
-      if digital_asm then
-        `      .quad   {emit_nativeint n}\n`
-      else
-        (* Work around a bug in gas regarding the parsing of
-           long decimal constants *)
-        `      .quad   0x{emit_string(Nativeint.format "%x" n)}\n`
-  | Csingle f ->
-      emit_float32_directive ".long" f
-  | Cdouble f ->
-      emit_float64_directive ".quad" f
-  | Csymbol_address s ->
-      `        .quad   {emit_symbol s}\n`
-  | Clabel_address lbl ->
-      `        .quad   {emit_label (100000 + lbl)}\n`
-  | Cstring s ->
-      emit_string_directive "  .ascii  " s
-  | Cskip n ->
-      if n > 0 then `  .space  {emit_int n}\n`
-  | Calign n ->
-      `        .align  {emit_int(Misc.log2 n)}\n`
-
-let data l =
-  `    .data\n`;
-  List.iter emit_item l
-
-(* Beginning / end of an assembly file *)
-
-let begin_assembly() =
-  (* There are really two groups of registers:
-      $sp and $15 always point to stack locations
-      $0 - $14, $16-$23 never point to stack locations. *)
-  `    .noalias $0,$sp;  .noalias $0,$15;  .noalias $1,$sp;  .noalias $1,$15\n`;
-  `    .noalias $2,$sp;  .noalias $2,$15;  .noalias $3,$sp;  .noalias $3,$15\n`;
-  `    .noalias $4,$sp;  .noalias $4,$15;  .noalias $5,$sp;  .noalias $5,$15\n`;
-  `    .noalias $6,$sp;  .noalias $6,$15;  .noalias $7,$sp;  .noalias $7,$15\n`;
-  `    .noalias $8,$sp;  .noalias $8,$15;  .noalias $9,$sp;  .noalias $9,$15\n`;
-  `    .noalias $10,$sp; .noalias $10,$15; .noalias $11,$sp; .noalias $11,$15\n`;
-  `    .noalias $12,$sp; .noalias $12,$15; .noalias $13,$sp; .noalias $13,$15\n`;
-  `    .noalias $14,$sp; .noalias $14,$15; .noalias $16,$sp; .noalias $16,$15\n`;
-  `    .noalias $17,$sp; .noalias $17,$15; .noalias $18,$sp; .noalias $18,$15\n`;
-  `    .noalias $19,$sp; .noalias $19,$15; .noalias $20,$sp; .noalias $20,$15\n`;
-  `    .noalias $21,$sp; .noalias $21,$15; .noalias $22,$sp; .noalias $22,$15\n`;
-  `    .noalias $23,$sp; .noalias $23,$15\n\n`;
-  (* The following .file directive is intended to prevent the generation
-     of line numbers for the debugger, 'cos they make .o files larger
-     and slow down linking. *)
-  `    .file   1 \"{emit_string !Location.input_name}\"\n\n`;
-  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
-  `    .data\n`;
-  `    .globl  {emit_symbol lbl_begin}\n`;
-  `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
-  `    .text\n`;
-  `    .globl  {emit_symbol lbl_begin}\n`;
-  `{emit_symbol lbl_begin}:\n`
-
-let end_assembly () =
-  let lbl_end = Compilenv.make_symbol (Some "code_end") in
-  `    .text\n`;
-  `    .globl  {emit_symbol lbl_end}\n`;
-  `{emit_symbol lbl_end}:\n`;
-  let lbl_end = Compilenv.make_symbol (Some "data_end") in
-  `    .data\n`;
-  `    .globl  {emit_symbol lbl_end}\n`;
-  `{emit_symbol lbl_end}:\n`;
-  `    .quad   0\n`;
-  let lbl_frame = Compilenv.make_symbol (Some "frametable") in
-  `    {emit_string rdata_section}\n`;
-  `    .globl  {emit_symbol lbl_frame}\n`;
-  `{emit_symbol lbl_frame}:\n`;
-  `    .quad   {emit_int (List.length !frame_descriptors)}\n`;
-  List.iter emit_frame !frame_descriptors;
-  frame_descriptors := []

diff --git a/asmcomp/alpha/proc.ml b/asmcomp/alpha/proc.ml
deleted file mode 100644 (file)
index 93c2422..0000000
--- a/asmcomp/alpha/proc.ml
+++ /dev/null
@@ -1,217 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Description of the Alpha processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Mach
-
-(* Instruction selection *)
-
-let word_addressed = true
-
-(* Registers available for register allocation *)
-
-(* Register map:
-    $0 - $7     0 - 7       function results
-    $8 - $12    8 - 12      general purpose ($9 - $15 are preserved by C)
-    $13                     allocation pointer
-    $14                     allocation limit
-    $15                     trap pointer
-    $16 - $22   13 - 19     function arguments
-    $23 - $25               temporaries (for the code gen and for the asm)
-    $26 - $30               stack ptr, global ptr, etc
-    $31                     always zero
-
-    $f0 - $f7   100 - 107   function results
-    $f8 - $f15  108 - 115   general purpose ($f2 - $f9 preserved by C)
-    $f16 - $f23 116 - 123   function arguments
-    $f24 - $f30 124 - 129   general purpose
-    $f28                    temporary
-    $f31                    always zero *)
-
-let int_reg_name = [|
-  (* 0-7 *)    "$0"; "$1"; "$2"; "$3"; "$4"; "$5"; "$6"; "$7";
-  (* 8-12 *)   "$8"; "$9"; "$10"; "$11"; "$12";
-  (* 13-19 *)  "$16"; "$17"; "$18"; "$19"; "$20"; "$21"; "$22"
-|]
-
-let float_reg_name = [|
-  (* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7";
-  (* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15";
-  (* 116-123 *) "$f16"; "$f17"; "$f18"; "$f19"; "$f20"; "$f21"; "$f22"; "$f23";
-  (* 124-129 *) "$f24"; "$f25"; "$f26"; "$f27"; "$f29"; "$f30"
-|]
-
-let num_register_classes = 2
-
-let register_class r =
-  match r.typ with
-    Int -> 0
-  | Addr -> 0
-  | Float -> 1
-
-let num_available_registers = [| 20; 30 |]
-
-let first_available_register = [| 0; 100 |]
-
-let register_name r =
-  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
-
-let rotate_registers = true
-
-(* Representation of hard registers by pseudo-registers *)
-
-let hard_int_reg =
-  let v = Array.create 20 Reg.dummy in
-  for i = 0 to 19 do v.(i) <- Reg.at_location Int (Reg i) done;
-  v
-
-let hard_float_reg =
-  let v = Array.create 30 Reg.dummy in
-  for i = 0 to 29 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done;
-  v
-
-let all_phys_regs =
-  Array.append hard_int_reg hard_float_reg
-
-let phys_reg n =
-  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
-
-let stack_slot slot ty =
-  Reg.at_location ty (Stack slot)
-
-(* Calling conventions *)
-
-let calling_conventions first_int last_int first_float last_float make_stack
-                        arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let int = ref first_int in
-  let float = ref first_float in
-  let ofs = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-      Int | Addr as ty ->
-        if !int <= last_int then begin
-          loc.(i) <- phys_reg !int;
-          incr int
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) ty;
-          ofs := !ofs + size_int
-        end
-    | Float ->
-        if !float <= last_float then begin
-          loc.(i) <- phys_reg !float;
-          incr float
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) Float;
-          ofs := !ofs + size_float
-        end
-  done;
-  (loc, Misc.align !ofs 16)         (* Keep stack 16-aligned *)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
-
-let loc_arguments arg =
-  calling_conventions 13 18 116 123 outgoing arg
-let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 13 18 116 123 incoming arg in loc
-let loc_results res =
-  let (loc, ofs) = calling_conventions 0 7 100 107 not_supported res in loc
-
-(* On the Alpha, C functions have calling conventions similar to those
-   for Caml functions, except that integer and floating-point registers
-   for arguments are allocated "in sequence". E.g. a function
-   taking a float f1 and two ints i2 and i3 will put f1 in the
-   first float reg, i2 in the second int reg and i3 in the third int reg. *)
-
-let ext_calling_conventions first_int last_int first_float last_float
-                            make_stack arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let int = ref first_int in
-  let float = ref first_float in
-  let ofs = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-      Int | Addr as ty ->
-        if !int <= last_int then begin
-          loc.(i) <- phys_reg !int; incr int; incr float
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) ty;
-          ofs := !ofs + size_int
-        end
-    | Float ->
-        if !float <= last_float then begin
-          loc.(i) <- phys_reg !float; incr int; incr float
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) Float;
-          ofs := !ofs + size_float
-        end
-  done;
-  (loc, Misc.align !ofs 16)             (* Keep stack 16-aligned *)
-
-let loc_external_arguments arg =
-  ext_calling_conventions 13 18 116 121 outgoing arg
-let loc_external_results res =
-  let (loc, ofs) = ext_calling_conventions 0 0 100 100 not_supported res in loc
-let extcall_use_push = false
-
-let loc_exn_bucket = phys_reg 0         (* $0 *)
-
-(* Registers destroyed by operations *)
-
-let destroyed_at_c_call =               (* $9 - $12, $f2 - $f9 preserved *)
-  Array.of_list(List.map phys_reg
-    [0;1;2;3;4;5;6;7;8;13;14;15;16;17;18;19;
-     100;101;110;111;112;113;114;115;116;117;118;119;120;121;122;123;124;
-     125;126;127;128;129])
-
-let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
-  | _ -> [||]
-
-let destroyed_at_raise = all_phys_regs
-
-(* Maximal register pressure *)
-
-let safe_register_pressure = function
-    Iextcall(_, _) -> 4
-  | _ -> 19
-let max_register_pressure = function
-    Iextcall(_, _) -> [| 4; 8 |]
-  | _ -> [| 19; 29 |]
-
-(* Layout of the stack *)
-
-let num_stack_slots = [| 0; 0 |]
-let contains_calls = ref false
-
-(* Calling the assembler *)
-
-let assemble_file infile outfile =
-  let as_cmd =
-    if digital_asm && !Clflags.gprofile
-    then Config.asm ^ " -pg"
-    else Config.asm in
-  Ccomp.command (as_cmd ^ " -o " ^
-                 Filename.quote outfile ^ " " ^ Filename.quote infile)
-
-open Clflags;;
-open Config;;

diff --git a/asmcomp/alpha/reload.ml b/asmcomp/alpha/reload.ml
deleted file mode 100644 (file)
index 53f7b18..0000000
--- a/asmcomp/alpha/reload.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Reloading for the Alpha *)
-
-let fundecl f =
-  (new Reloadgen.reload_generic)#fundecl f

diff --git a/asmcomp/alpha/scheduling.ml b/asmcomp/alpha/scheduling.ml
deleted file mode 100644 (file)
index f59c26e..0000000
--- a/asmcomp/alpha/scheduling.ml
+++ /dev/null
@@ -1,70 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Arch
-open Mach
-
-(* The Digital Unix assembler does scheduling better than us.
-   However, the Linux-Alpha assembler does not do scheduling, so we do
-   a feeble attempt here. *)
-
-class scheduler = object (self)
-
-inherit Schedgen.scheduler_generic as super
-
-(* Latencies (in cycles). Based on the 21064, with some poetic license. *)
-
-method oper_latency = function
-    Ireload -> 3
-  | Iload(_, _) -> 3
-  | Iconst_symbol _ -> 3 (* turned into a load *)
-  | Iconst_float _ -> 3 (* ends up in a load *)
-  | Iintop(Imul) -> 23
-  | Iintop_imm(Imul, _) -> 23
-  | Iaddf -> 6
-  | Isubf -> 6
-  | Imulf -> 6
-  | Idivf -> 63
-  | _ -> 2
-    (* Most arithmetic instructions can be executed back-to-back in 1 cycle.
-       However, some combinations (arith; load or arith; store) require 2
-       cycles.  Also, by claiming 2 cycles instead of 1, we might favor
-       dual issue. *)
-
-(* Issue cycles.  Rough approximations. *)
-
-method oper_issue_cycles = function
-    Iconst_float _ -> 4                 (* load from $gp, then load *)
-  | Ialloc _ -> 4
-  | Iintop(Icheckbound) -> 2
-  | Iintop_imm(Idiv, _) -> 3
-  | Iintop_imm(Imod, _) -> 5
-  | Iintop_imm(Icheckbound, _) -> 2
-  | Ifloatofint -> 10
-  | Iintoffloat -> 10
-  | _ -> 1
-
-(* Say that reloadgp is not part of a basic block (prevents moving it
-   past an operation that uses $gp) *)
-
-method oper_in_basic_block = function
-    Ispecific(Ireloadgp _) -> false
-  | op -> super#oper_in_basic_block op
-
-end
-
-let fundecl =
-  if digital_asm
-  then (fun f -> f)
-  else (new scheduler)#schedule_fundecl

diff --git a/asmcomp/alpha/selection.ml b/asmcomp/alpha/selection.ml
deleted file mode 100644 (file)
index d91ec5b..0000000
--- a/asmcomp/alpha/selection.ml
+++ /dev/null
@@ -1,83 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Instruction selection for the Alpha processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Mach
-
-class selector = object (self)
-
-inherit Selectgen.selector_generic as super
-
-method is_immediate n = digital_asm || (n >= 0 && n <= 255)
-
-method select_addressing = function
-    (* Force an explicit lda for non-scheduling assemblers,
-       this allows our scheduler to do a better job. *)
-    Cconst_symbol s when digital_asm ->
-      (Ibased(s, 0), Ctuple [])
-  | Cop((Cadda | Caddi), [Cconst_symbol s; Cconst_int n]) when digital_asm ->
-      (Ibased(s, n), Ctuple [])
-  | Cop((Cadda | Caddi), [arg; Cconst_int n]) ->
-      (Iindexed n, arg)
-  | Cop((Cadda | Caddi), [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
-      (Iindexed n, Cop(Cadda, [arg1; arg2]))
-  | arg ->
-      (Iindexed 0, arg)
-
-method! select_operation op args =
-  match (op, args) with
-    (* Recognize shift-add operations *)
-    ((Caddi|Cadda),
-     [arg2; Cop(Clsl, [arg1; Cconst_int(2|3 as shift)])]) ->
-      (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2])
-  | ((Caddi|Cadda),
-     [arg2; Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)])]) ->
-      (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
-  | ((Caddi|Cadda),
-     [arg2; Cop(Cmuli, [Cconst_int(4|8 as mult); arg1])]) ->
-      (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
-  | (Caddi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) ->
-      (Ispecific(if shift = 2 then Iadd4 else Iadd8), [arg1; arg2])
-  | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(4|8 as mult)]); arg2]) ->
-      (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
-  | (Caddi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) ->
-      (Ispecific(if mult = 4 then Iadd4 else Iadd8), [arg1; arg2])
-  | (Csubi, [Cop(Clsl, [arg1; Cconst_int(2|3 as shift)]); arg2]) ->
-      (Ispecific(if shift = 2 then Isub4 else Isub8), [arg1; arg2])
-  | (Csubi, [Cop(Cmuli, [Cconst_int(4|8 as mult); arg1]); arg2]) ->
-      (Ispecific(if mult = 4 then Isub4 else Isub8), [arg1; arg2])
-    (* Recognize truncation/normalization of 64-bit integers to 32 bits *)
-  | (Casr, [Cop(Clsl, [arg; Cconst_int 32]); Cconst_int 32]) ->
-      (Ispecific Itrunc32, [arg])
-    (* Work around various limitations of the GNU assembler *)
-  | ((Caddi|Cadda), [arg1; Cconst_int n])
-    when not (self#is_immediate n) && self#is_immediate (-n) ->
-      (Iintop_imm(Isub, -n), [arg1])
-  | (Cdivi, [arg1; Cconst_int n])
-    when (not digital_asm) && n <> 1 lsl (Misc.log2 n) ->
-      (Iintop Idiv, args)
-  | (Cmodi, [arg1; Cconst_int n])
-    when (not digital_asm) && n <> 1 lsl (Misc.log2 n) ->
-      (Iintop Imod, args)
-  | _ ->
-      super#select_operation op args
-
-end
-
-let fundecl f = (new selector)#emit_fundecl f

diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml
index 3e8f4b1113361711c16e1b103efbf7392bd7ea56..8e065d9ae09f4426beeed87fc26b699f9bbeae2d 100644 (file)
--- a/asmcomp/amd64/arch.ml
+++ b/asmcomp/amd64/arch.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -51,6 +51,10 @@ let size_addr = 8
 let size_int = 8
 let size_float = 8
 
+(* Behavior of division *)
+
+let division_crashes_on_overflow = true
+
 (* Operations on addressing modes *)
 
 let identity_addressing = Iindexed 0

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index a33a0fa9cd74f93d44517678cbd018074b0b59dc..7dd55c964f4758950daa44aa19b4bd5e6e1bc251 100644 (file)
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -23,11 +23,8 @@ open Mach
 open Linearize
 open Emitaux
 
-let macosx =
-  match Config.system with
-  | "macosx" -> true
-  | _ -> false
-
+let macosx = (Config.system = "macosx")
+let mingw64 = (Config.system = "mingw64")
 
 (* Tradeoff between code size and code speed *)
 
@@ -64,17 +61,17 @@ let emit_symbol s =
     Emitaux.emit_symbol '$' s
 
 let emit_call s =
-  if !Clflags.dlcode && not macosx
+  if !Clflags.dlcode && not macosx && not mingw64
   then `call   {emit_symbol s}@PLT`
   else `call   {emit_symbol s}`
 
 let emit_jump s =
-  if !Clflags.dlcode && not macosx
+  if !Clflags.dlcode && not macosx && not mingw64
   then `jmp    {emit_symbol s}@PLT`
   else `jmp    {emit_symbol s}`
 
 let load_symbol_addr s =
-  if !Clflags.dlcode
+  if !Clflags.dlcode && not mingw64
   then `movq   {emit_symbol s}@GOTPCREL(%rip)`
   else if !pic_code
   then `leaq   {emit_symbol s}(%rip)`
@@ -85,6 +82,9 @@ let load_symbol_addr s =
 let emit_label lbl =
   emit_string ".L"; emit_int lbl
 
+let emit_data_label lbl =
+  emit_string ".Ld"; emit_int lbl
+
 (* Output a .align directive. *)
 
 let emit_align n =
@@ -317,11 +317,17 @@ let emit_float_test cmp neg arg lbl =
 
 (* Deallocate the stack frame before a return or tail call *)
 
-let output_epilogue () =
+let output_epilogue f =
   if frame_required() then begin
     let n = frame_size() - 8 in
-    `  addq    ${emit_int n}, %rsp\n`
+    `  addq    ${emit_int n}, %rsp\n`;
+    cfi_adjust_cfa_offset (-n);
+    f ();
+    (* reset CFA back cause function body may continue *)
+    cfi_adjust_cfa_offset n
   end
+  else
+    f ()
 
 (* Output the assembly code for an instruction *)
 
@@ -332,7 +338,9 @@ let tailrec_entry_point = ref 0
 
 let float_constants = ref ([] : (int * string) list)
 
+(* Emit an instruction *)
 let emit_instr fallthrough i =
+    emit_debug_info i.dbg;
     match i.desc with
       Lend -> ()
     | Lop(Imove | Ispill | Ireload) ->
@@ -373,14 +381,16 @@ let emit_instr fallthrough i =
         `      {emit_call s}\n`;
         record_frame i.live i.dbg
     | Lop(Itailcall_ind) ->
-        output_epilogue();
+        output_epilogue begin fun () ->
         `      jmp     *{emit_reg i.arg.(0)}\n`
+        end
     | Lop(Itailcall_imm s) ->
         if s = !function_name then
           `    jmp     {emit_label !tailrec_entry_point}\n`
         else begin
-          output_epilogue();
+          output_epilogue begin fun () ->
           `    {emit_jump s}\n`
+          end
         end
     | Lop(Iextcall(s, alloc)) ->
         if alloc then begin
@@ -394,6 +404,7 @@ let emit_instr fallthrough i =
         if n < 0
         then ` addq    ${emit_int(-n)}, %rsp\n`
         else ` subq    ${emit_int(n)}, %rsp\n`;
+        cfi_adjust_cfa_offset n;
         stack_offset := !stack_offset + n
     | Lop(Iload(chunk, addr)) ->
         let dest = i.res.(0) in
@@ -536,8 +547,9 @@ let emit_instr fallthrough i =
     | Lreloadretaddr ->
         ()
     | Lreturn ->
-        output_epilogue();
+        output_epilogue begin fun () ->
         `      ret\n`
+        end
     | Llabel lbl ->
         `{emit_Llabel fallthrough lbl}:\n`
     | Lbranch lbl ->
@@ -601,9 +613,12 @@ let emit_instr fallthrough i =
         `      movslq  ({emit_reg tmp1}, {emit_reg i.arg.(0)}, 4), {emit_reg tmp2}\n`;
         `      addq    {emit_reg tmp2}, {emit_reg tmp1}\n`;
         `      jmp     *{emit_reg tmp1}\n`;
-        if macosx
-        then ` .const\n`
-        else ` .section .rodata\n`;
+        if macosx then
+          `    .const\n`
+        else if mingw64 then
+          `    .section .rdata,\"dr\"\n`
+        else
+          `    .section .rodata\n`;
         emit_align 4;
         `{emit_label lbl}:`;
         for i = 0 to Array.length jumptbl - 1 do
@@ -613,12 +628,16 @@ let emit_instr fallthrough i =
     | Lsetuptrap lbl ->
         `      call    {emit_label lbl}\n`
     | Lpushtrap ->
+        cfi_adjust_cfa_offset 8;
         `      pushq   %r14\n`;
+        cfi_adjust_cfa_offset 8;
         `      movq    %rsp, %r14\n`;
         stack_offset := !stack_offset + 16
     | Lpoptrap ->
         `      popq    %r14\n`;
+        cfi_adjust_cfa_offset (-8);
         `      addq    $8, %rsp\n`;
+        cfi_adjust_cfa_offset (-8);
         stack_offset := !stack_offset - 16
     | Lraise ->
         if !Clflags.debug then begin
@@ -650,7 +669,7 @@ let emit_profile () =
   | "linux" | "gnu" ->
       (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly
          and rbx, rbp, r12-r15 like all C functions.
-         We need to preserve r10 and r11 ourselves, since Caml can
+         We need to preserve r10 and r11 ourselves, since OCaml can
          use them for argument passing. *)
       `        pushq   %r10\n`;
       `        movq    %rsp, %rbp\n`;
@@ -682,15 +701,19 @@ let fundecl fundecl =
   else
     `  .globl  {emit_symbol fundecl.fun_name}\n`;
   `{emit_symbol fundecl.fun_name}:\n`;
+  emit_debug_info fundecl.fun_dbg;
+  cfi_startproc ();
   if !Clflags.gprofile then emit_profile();
   if frame_required() then begin
     let n = frame_size() - 8 in
-    `  subq    ${emit_int n}, %rsp\n`
+    `  subq    ${emit_int n}, %rsp\n`;
+    cfi_adjust_cfa_offset n;
   end;
   `{emit_label !tailrec_entry_point}:\n`;
   emit_all true fundecl.fun_body;
   List.iter emit_call_gc !call_gc_sites;
   emit_call_bound_errors ();
+  cfi_endproc ();
   begin match Config.system with
     "linux" | "gnu" ->
       `        .type   {emit_symbol fundecl.fun_name},@function\n`;
@@ -698,9 +721,12 @@ let fundecl fundecl =
     | _ -> ()
   end;
   if !float_constants <> [] then begin
-    if macosx
-    then `     .literal8\n`
-    else `     .section        .rodata.cst8,\"a\",@progbits\n`;
+    if macosx then
+      `        .literal8\n`
+    else if mingw64 then
+      `        .section .rdata,\"dr\"\n`
+    else
+      `        .section .rodata.cst8,\"a\",@progbits\n`;
     List.iter emit_float_constant !float_constants
   end
 
@@ -712,7 +738,7 @@ let emit_item = function
   | Cdefine_symbol s ->
       `{emit_symbol s}:\n`
   | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)}:\n`
+      `{emit_data_label lbl}:\n`
   | Cint8 n ->
       `        .byte   {emit_int n}\n`
   | Cint16 n ->
@@ -728,7 +754,7 @@ let emit_item = function
   | Csymbol_address s ->
       `        .quad   {emit_symbol s}\n`
   | Clabel_address lbl ->
-      `        .quad   {emit_label (100000 + lbl)}\n`
+      `        .quad   {emit_data_label lbl}\n`
   | Cstring s ->
       emit_string_directive "  .ascii  " s
   | Cskip n ->
@@ -746,9 +772,11 @@ let begin_assembly() =
   if !Clflags.dlcode then begin
     (* from amd64.S; could emit these constants on demand *)
     if macosx then
-        `      .literal16\n`
+      `        .literal16\n`
+    else if mingw64 then
+      `        .section .rdata,\"dr\"\n`
     else
-        `      .section        .rodata.cst8,\"a\",@progbits\n`;
+      `        .section .rodata.cst8,\"a\",@progbits\n`;
     emit_align 16;
     `{emit_symbol "caml_negf_mask"}:   .quad   0x8000000000000000, 0\n`;
     emit_align 16;

diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp
index 724d6ee01619a10118cea0f3d324d598c509c34a..6dbbb83e6ef2a8366da6968c007c44a510ffbe4f 100644 (file)
--- a/asmcomp/amd64/emit_nt.mlp
+++ b/asmcomp/amd64/emit_nt.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -80,6 +80,9 @@ let add_used_symbol s =
 let emit_label lbl =
   emit_string "L"; emit_int lbl
 
+let emit_data_label lbl =
+  emit_string "Ld"; emit_int lbl
+
 (* Output a .align directive. *)
 
 let emit_align n =
@@ -591,19 +594,24 @@ let emit_instr fallthrough i =
             end
     | Lswitch jumptbl ->
         let lbl = new_label() in
-        if !pic_code then begin
-          `    lea     r11, {emit_label lbl}\n`;
-          `    jmp     QWORD PTR [r11+{emit_reg i.arg.(0)}*8]\n`
-        end else begin
-          `    jmp     QWORD PTR [{emit_reg i.arg.(0)}*8 + {emit_label lbl}]\n`
-        end;
-        `      .DATA\n`;
-        emit_align 8;
-        `{emit_label lbl}      LABEL QWORD\n`;
+        (* rax and rdx are clobbered by the Lswitch,
+           meaning that no variable that is live across the Lswitch
+           is assigned to rax or rdx.  However, the argument to Lswitch
+           can still be assigned to one of these two registers, so
+           we must be careful not to clobber it before use. *)
+        let (tmp1, tmp2) =
+          if i.arg.(0).loc = Reg 0 (* rax *)
+          then (phys_reg 4 (*rdx*), phys_reg 0 (*rax*))
+          else (phys_reg 0 (*rax*), phys_reg 4 (*rdx*)) in
+        `      lea     {emit_reg tmp1}, {emit_label lbl}\n`;
+        `      movsxd  {emit_reg tmp2}, DWORD PTR [{emit_reg tmp1}+{emit_reg i.arg.(0)}*4]\n`;
+        `      add     {emit_reg tmp1}, {emit_reg tmp2}\n`;
+        `      jmp     {emit_reg tmp1}\n`;
+        emit_align 4;
+        `{emit_label lbl}      LABEL DWORD\n`;
         for i = 0 to Array.length jumptbl - 1 do
-          `    QWORD   {emit_label jumptbl.(i)}\n`
-        done;
-        `      .CODE\n`
+          `    DWORD   {emit_label jumptbl.(i)} - {emit_label lbl}\n`
+        done
     | Lsetuptrap lbl ->
         `      call    {emit_label lbl}\n`
     | Lpushtrap ->
@@ -691,7 +699,7 @@ let emit_item = function
       add_def_symbol s;
       `{emit_symbol s} LABEL QWORD\n`
   | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)} LABEL QWORD\n`
+      `{emit_data_label lbl} LABEL QWORD\n`
   | Cint8 n ->
       `        BYTE    {emit_int n}\n`
   | Cint16 n ->
@@ -708,7 +716,7 @@ let emit_item = function
       add_used_symbol s;
       `        QWORD   {emit_symbol s}\n`
   | Clabel_address lbl ->
-      `        QWORD   {emit_label (100000 + lbl)}\n`
+      `        QWORD   {emit_data_label lbl}\n`
   | Cstring s ->
       emit_bytes_directive "   BYTE    " s
   | Cskip n ->

diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml
index 4ba0d5c3ec29a05547e9ba273e211c92bff3a801..01132e6cbbb3a1a737fe0915b803bf8007772e6b 100644 (file)
--- a/asmcomp/amd64/proc.ml
+++ b/asmcomp/amd64/proc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,13 +20,27 @@ open Cmm
 open Reg
 open Mach
 
+(* Which ABI to use *)
+
+let win64 =
+  match Config.system with
+  | "win64" | "mingw64" -> true
+  | _                   -> false
+
+(* Which asm conventions to use *)
+
+let masm =
+  match Config.ccomp_type with
+  | "msvc" -> true
+  | _      -> false
+
 (* Registers available for register allocation *)
 
 (* Register map:
-    rax         0               rax - r11: Caml function arguments
-    rbx         1               rdi - r9: C function arguments
-    rdi         2               rax: Caml and C function results
-    rsi         3               rbx, rbp, r12-r15 are preserved by C
+    rax         0
+    rbx         1
+    rdi         2
+    rsi         3
     rdx         4
     rcx         5
     r8          6
@@ -39,18 +53,44 @@ open Mach
     r14         trap pointer
     r15         allocation pointer
 
-  xmm0 - xmm15  100 - 115       xmm0 - xmm9: Caml function arguments
-                                xmm0 - xmm7: C function arguments
-                                xmm0: Caml and C function results *)
+  xmm0 - xmm15  100 - 115  *)
+
+(* Conventions:
+     rax - r11: OCaml function arguments
+     rax: OCaml and C function results
+     xmm0 - xmm9: OCaml function arguments
+     xmm0: OCaml and C function results
+   Under Unix:
+     rdi, rsi, rdx, rcx, r8, r9: C function arguments
+     xmm0 - xmm7: C function arguments
+     rbx, rbp, r12-r15 are preserved by C
+     xmm registers are not preserved by C
+   Under Win64:
+     rcx, rdx, r8, r9: C function arguments
+     xmm0 - xmm3: C function arguments
+     rbx, rbp, rsi, rdi r12-r15 are preserved by C
+     xmm6-xmm15 are preserved by C
+*)
 
 let int_reg_name =
-  [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9";
-     "%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |]
+  match Config.ccomp_type with
+  | "msvc" ->
+      [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9";
+         "r10"; "r11"; "rbp"; "r12"; "r13" |]
+  | _ ->
+      [| "%rax"; "%rbx"; "%rdi"; "%rsi"; "%rdx"; "%rcx"; "%r8"; "%r9";
+         "%r10"; "%r11"; "%rbp"; "%r12"; "%r13" |]
 
 let float_reg_name =
-  [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7";
-     "%xmm8"; "%xmm9"; "%xmm10"; "%xmm11";
-     "%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |]
+  match Config.ccomp_type with
+  | "msvc" ->
+      [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7";
+         "xmm8"; "xmm9"; "xmm10"; "xmm11";
+         "xmm12"; "xmm13"; "xmm14"; "xmm15" |]
+  | _ ->
+      [| "%xmm0"; "%xmm1"; "%xmm2"; "%xmm3"; "%xmm4"; "%xmm5"; "%xmm6"; "%xmm7";
+         "%xmm8"; "%xmm9"; "%xmm10"; "%xmm11";
+         "%xmm12"; "%xmm13"; "%xmm14"; "%xmm15" |]
 
 let num_register_classes = 2
 
@@ -141,26 +181,74 @@ let loc_parameters arg =
 let loc_results res =
   let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
 
-(* C calling convention:
+(* C calling conventions under Unix:
      first integer args in rdi, rsi, rdx, rcx, r8, r9
      first float args in xmm0 ... xmm7
-     remaining args on stack.
-   Return value in rax or xmm0. *)
+     remaining args on stack
+     return value in rax or xmm0.
+  C calling conventions under Win64:
+     first integer args in rcx, rdx, r8, r9
+     first float args in xmm0 ... xmm3     
+     each integer arg consumes a float reg, and conversely
+     remaining args on stack
+     always 32 bytes reserved at bottom of stack.
+     Return value in rax or xmm0. *)
 
-let loc_external_arguments arg =
-  calling_conventions 2 7 100 107 outgoing arg
 let loc_external_results res =
   let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
 
+let unix_loc_external_arguments arg =
+  calling_conventions 2 7 100 107 outgoing arg
+
+let win64_int_external_arguments =
+  [| 5 (*rcx*); 4 (*rdx*); 6 (*r8*); 7 (*r9*) |]
+let win64_float_external_arguments =
+  [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |]
+
+let win64_loc_external_arguments arg =
+  let loc = Array.create (Array.length arg) Reg.dummy in
+  let reg = ref 0
+  and ofs = ref 32 in
+  for i = 0 to Array.length arg - 1 do
+    match arg.(i).typ with
+      Int | Addr as ty ->
+        if !reg < 4 then begin
+          loc.(i) <- phys_reg win64_int_external_arguments.(!reg);
+          incr reg
+        end else begin
+          loc.(i) <- stack_slot (Outgoing !ofs) ty;
+          ofs := !ofs + size_int
+        end
+    | Float ->
+        if !reg < 4 then begin
+          loc.(i) <- phys_reg win64_float_external_arguments.(!reg);
+          incr reg
+        end else begin
+          loc.(i) <- stack_slot (Outgoing !ofs) Float;
+          ofs := !ofs + size_float
+        end
+  done;
+  (loc, Misc.align !ofs 16)  (* keep stack 16-aligned *)
+
+let loc_external_arguments =
+  if win64 then win64_loc_external_arguments else unix_loc_external_arguments
+
 let loc_exn_bucket = rax
 
 (* Registers destroyed by operations *)
 
-let destroyed_at_c_call =         (* rbp, rbx, r12-r15 preserved *)
-  Array.of_list(List.map phys_reg
-    [0;2;3;4;5;6;7;8;9;
-     100;101;102;103;104;105;106;107;
-     108;109;110;111;112;113;114;115])
+let destroyed_at_c_call =
+  if win64 then
+    (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *)
+    Array.of_list(List.map phys_reg
+      [0;4;5;6;7;8;9;
+       100;101;102;103;104;105])
+  else
+    (* Unix: rbp, rbx, r12-r15 preserved *)
+    Array.of_list(List.map phys_reg
+      [0;2;3;4;5;6;7;8;9;
+       100;101;102;103;104;105;106;107;
+       108;109;110;111;112;113;114;115])
 
 let destroyed_at_oper = function
     Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
@@ -177,11 +265,11 @@ let destroyed_at_raise = all_phys_regs
 (* Maximal register pressure *)
 
 let safe_register_pressure = function
-    Iextcall(_,_) -> 0
+    Iextcall(_,_) -> if win64 then 8 else 0
   | _ -> 11
 
 let max_register_pressure = function
-    Iextcall(_, _) -> [| 4; 0 |]
+    Iextcall(_, _) -> if win64 then [| 8; 10 |] else [| 4; 0 |]
   | Iintop(Idiv | Imod) -> [| 11; 16 |]
   | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)
         -> [| 12; 16 |]
@@ -196,5 +284,10 @@ let contains_calls = ref false
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
-  Ccomp.command (Config.asm ^ " -o " ^
-                 Filename.quote outfile ^ " " ^ Filename.quote infile)
+  if masm then
+    Ccomp.command (Config.asm ^
+                   Filename.quote outfile ^ " " ^ Filename.quote infile ^
+                   (if !Clflags.verbose then "" else ">NUL"))
+  else
+    Ccomp.command (Config.asm ^ " -o " ^
+                   Filename.quote outfile ^ " " ^ Filename.quote infile)

diff --git a/asmcomp/amd64/proc_nt.ml b/asmcomp/amd64/proc_nt.ml
deleted file mode 100644 (file)
index 5c90e4f..0000000
--- a/asmcomp/amd64/proc_nt.ml
+++ /dev/null
@@ -1,233 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Description of the AMD64 processor with Win64 conventions *)
-
-open Misc
-open Arch
-open Cmm
-open Reg
-open Mach
-
-(* Registers available for register allocation *)
-
-(* Register map:
-    rax         0               rax - r11: Caml function arguments
-    rbx         1               rcx - r9: C function arguments
-    rdi         2               rax: Caml and C function results
-    rsi         3               rbx, rbp, rsi, rdi r12-r15 are preserved by C
-    rdx         4
-    rcx         5
-    r8          6
-    r9          7
-    r10         8
-    r11         9
-    rbp         10
-    r12         11
-    r13         12
-    r14         trap pointer
-    r15         allocation pointer
-
-  xmm0 - xmm15  100 - 115       xmm0 - xmm9: Caml function arguments
-                                xmm0 - xmm3: C function arguments
-                                xmm0: Caml and C function results
-                                xmm6-xmm15 are preserved by C *)
-
-let int_reg_name =
-  [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9";
-     "r10"; "r11"; "rbp"; "r12"; "r13" |]
-
-let float_reg_name =
-  [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7";
-     "xmm8"; "xmm9"; "xmm10"; "xmm11"; "xmm12"; "xmm13"; "xmm14"; "xmm15" |]
-
-let num_register_classes = 2
-
-let register_class r =
-  match r.typ with
-    Int -> 0
-  | Addr -> 0
-  | Float -> 1
-
-let num_available_registers = [| 13; 16 |]
-
-let first_available_register = [| 0; 100 |]
-
-let register_name r =
-  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
-
-(* Pack registers starting at %rax so as to reduce the number of REX
-   prefixes and thus improve code density *)
-let rotate_registers = false
-
-(* Representation of hard registers by pseudo-registers *)
-
-let hard_int_reg =
-  let v = Array.create 13 Reg.dummy in
-  for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done;
-  v
-
-let hard_float_reg =
-  let v = Array.create 16 Reg.dummy in
-  for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done;
-  v
-
-let all_phys_regs =
-  Array.append hard_int_reg hard_float_reg
-
-let phys_reg n =
-  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
-
-let rax = phys_reg 0
-let rcx = phys_reg 5
-let rdx = phys_reg 4
-let r11 = phys_reg 9
-let rxmm15 = phys_reg 115
-
-let stack_slot slot ty =
-  Reg.at_location ty (Stack slot)
-
-(* Instruction selection *)
-
-let word_addressed = false
-
-(* Calling conventions *)
-
-let calling_conventions first_int last_int first_float last_float make_stack
-                        arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let int = ref first_int in
-  let float = ref first_float in
-  let ofs = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-      Int | Addr as ty ->
-        if !int <= last_int then begin
-          loc.(i) <- phys_reg !int;
-          incr int
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) ty;
-          ofs := !ofs + size_int
-        end
-    | Float ->
-        if !float <= last_float then begin
-          loc.(i) <- phys_reg !float;
-          incr float
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) Float;
-          ofs := !ofs + size_float
-        end
-  done;
-  (loc, Misc.align !ofs 16)  (* keep stack 16-aligned *)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
-
-let loc_arguments arg =
-  calling_conventions 0 9 100 109 outgoing arg
-let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc
-let loc_results res =
-  let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
-
-(* C calling conventions (Win64):
-     first integer args in rcx, rdx, r8, r9  (4 - 7)
-     first float args in xmm0 ... xmm3       (100 - 103)
-     each integer arg consumes a float reg, and conversely
-     remaining args on stack
-     always 32 bytes reserved at bottom of stack.
-     Return value in rax or xmm0
-*)
-
-let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
-
-let int_external_arguments =
-  [| 5 (*rcx*); 4 (*rdx*); 6 (*r8*); 7 (*r9*) |]
-let float_external_arguments =
-  [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |]
-
-let loc_external_arguments arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let reg = ref 0
-  and ofs = ref 32 in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-      Int | Addr as ty ->
-        if !reg < 4 then begin
-          loc.(i) <- phys_reg int_external_arguments.(!reg);
-          incr reg
-        end else begin
-          loc.(i) <- stack_slot (Outgoing !ofs) ty;
-          ofs := !ofs + size_int
-        end
-    | Float ->
-        if !reg < 4 then begin
-          loc.(i) <- phys_reg float_external_arguments.(!reg);
-          incr reg
-        end else begin
-          loc.(i) <- stack_slot (Outgoing !ofs) Float;
-          ofs := !ofs + size_float
-        end
-  done;
-  (loc, Misc.align !ofs 16)  (* keep stack 16-aligned *)
-
-let loc_exn_bucket = rax
-
-(* Registers destroyed by operations *)
-
-let destroyed_at_c_call =
-  (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *)
-  Array.of_list(List.map phys_reg
-    [0;4;5;6;7;8;9;
-     100;101;102;103;104;105])
-
-let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
-  | Iop(Iintop(Idiv | Imod)) -> [| rax; rdx |]
-  | Iop(Istore(Single, _)) -> [| rxmm15 |]
-  | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _))
-        -> [| rax |]
-  | Iswitch(_, _) when !pic_code -> [| r11 |]
-  | _ -> [||]
-
-let destroyed_at_raise = all_phys_regs
-
-(* Maximal register pressure *)
-
-let safe_register_pressure = function
-    Iextcall(_,_) -> 8
-  | _ -> 11
-
-let max_register_pressure = function
-    Iextcall(_, _) -> [| 8; 10 |]
-  | Iintop(Idiv | Imod) -> [| 11; 16 |]
-  | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)
-        -> [| 12; 16 |]
-  | Istore(Single, _) -> [| 13; 15 |]
-  | _ -> [| 13; 16 |]
-
-(* Layout of the stack frame *)
-
-let num_stack_slots = [| 0; 0 |]
-let contains_calls = ref false
-
-(* Calling the assembler *)
-
-let assemble_file infile outfile =
-  Ccomp.command (Config.asm ^
-                 Filename.quote outfile ^ " " ^
-                 Filename.quote infile ^ "> NUL")

diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml
index 66772de97aea3c06a96b0806a31fe1e9cdff2ac1..e7d5e23b02348aeb56521588fd1d7b492bb26712 100644 (file)
--- a/asmcomp/amd64/reload.ml
+++ b/asmcomp/amd64/reload.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/amd64/scheduling.ml b/asmcomp/amd64/scheduling.ml
index faf0353ed6378dff5cbe09c3db5133feaf65cda9..8ba88f4a7963cfbb9a1c7a8f38f1ef2ad6b29180 100644 (file)
--- a/asmcomp/amd64/scheduling.ml
+++ b/asmcomp/amd64/scheduling.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml
index 4921e5110aab46a3fac4dad2865bd1600db229a8..9c4464aed9f0a6925b7f368b70c707d6433fb4bf 100644 (file)
--- a/asmcomp/amd64/selection.ml
+++ b/asmcomp/amd64/selection.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -121,7 +121,7 @@ method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000
 
 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n
 
-method select_addressing exp =
+method select_addressing chunk exp =
   let (a, d) = select_addr exp in
   (* PR#4625: displacement must be a signed 32-bit immediate *)
   if d < -0x8000_0000 || d > 0x7FFF_FFFF
@@ -157,7 +157,7 @@ method! select_operation op args =
   match op with
   (* Recognize the LEA instruction *)
     Caddi | Cadda | Csubi | Csuba ->
-      begin match self#select_addressing (Cop(op, args)) with
+      begin match self#select_addressing Word (Cop(op, args)) with
         (Iindexed d, _) -> super#select_operation op args
       | (Iindexed2 0, _) -> super#select_operation op args
       | (addr, arg) -> (Ispecific(Ilea addr), [arg])
@@ -191,7 +191,7 @@ method! select_operation op args =
       begin match args with
         [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
         when loc = loc' && self#is_immediate n ->
-          let (addr, arg) = self#select_addressing loc in
+          let (addr, arg) = self#select_addressing Word loc in
           (Ispecific(Ioffset_loc(n, addr)), [arg])
       | _ ->
           super#select_operation op args
@@ -202,12 +202,12 @@ method! select_operation op args =
 
 method select_floatarith commutative regular_op mem_op args =
   match args with
-    [arg1; Cop(Cload (Double|Double_u), [loc2])] ->
-      let (addr, arg2) = self#select_addressing loc2 in
+    [arg1; Cop(Cload (Double|Double_u as chunk), [loc2])] ->
+      let (addr, arg2) = self#select_addressing chunk loc2 in
       (Ispecific(Ifloatarithmem(mem_op, addr)),
                  [arg1; arg2])
-  | [Cop(Cload (Double|Double_u), [loc1]); arg2] when commutative ->
-      let (addr, arg1) = self#select_addressing loc1 in
+  | [Cop(Cload (Double|Double_u as chunk), [loc1]); arg2] when commutative ->
+      let (addr, arg1) = self#select_addressing chunk loc1 in
       (Ispecific(Ifloatarithmem(mem_op, addr)),
                  [arg2; arg1])
   | [arg1; arg2] ->
@@ -227,9 +227,6 @@ method! insert_op_debug op dbg rs rd =
   with Use_default ->
     super#insert_op_debug op dbg rs rd
 
-method! insert_op op rs rd =
-  self#insert_op_debug op Debuginfo.none rs rd
-
 end
 
 let fundecl f = (new selector)#emit_fundecl f

diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml
index aafb094b72b16aebe94289f96fa114f088022e91..c4aca8df0f0779e6756b67729889a0348dbbda74 100644 (file)
--- a/asmcomp/arm/arch.ml
+++ b/asmcomp/arm/arch.ml
@@ -1,12 +1,13 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  Benedikt Meurer, University of Siegen              *)
 (*                                                                     *)
-(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
+(*    Copyright 1998 Institut National de Recherche en Informatique    *)
+(*    et en Automatique. Copyright 2012 Benedikt Meurer. All rights    *)
+(*    reserved.  This file is distributed  under the terms of the Q    *)
+(*    Public License version 1.0.                                      *)
 (*                                                                     *)
 (***********************************************************************)
 
@@ -17,9 +18,81 @@
 open Misc
 open Format
 
+type abi = EABI | EABI_VFP
+type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7
+type fpu = Soft | VFPv3_D16 | VFPv3
+
+let abi =
+  match Config.system with
+    "linux_eabi"   -> EABI
+  | "linux_eabihf" -> EABI_VFP
+  | _ -> assert false
+
+let string_of_arch = function
+    ARMv4   -> "armv4"
+  | ARMv5   -> "armv5"
+  | ARMv5TE -> "armv5te"
+  | ARMv6   -> "armv6"
+  | ARMv6T2 -> "armv6t2"
+  | ARMv7   -> "armv7"
+
+let string_of_fpu = function
+    Soft      -> "soft"
+  | VFPv3_D16 -> "vfpv3-d16"
+  | VFPv3     -> "vfpv3"
+
 (* Machine-specific command-line options *)
 
-let command_line_options = []
+let (arch, fpu, thumb) =
+  let (def_arch, def_fpu, def_thumb) =
+    begin match abi, Config.model with
+    (* Defaults for architecture, FPU and Thumb *)
+      EABI, "armv5"   -> ARMv5,   Soft,      false
+    | EABI, "armv5te" -> ARMv5TE, Soft,      false
+    | EABI, "armv6"   -> ARMv6,   Soft,      false
+    | EABI, "armv6t2" -> ARMv6T2, Soft,      false
+    | EABI, "armv7"   -> ARMv7,   Soft,      false
+    | EABI, _         -> ARMv4,   Soft,      false
+    | EABI_VFP, _     -> ARMv7,   VFPv3_D16, true
+    end in
+  (ref def_arch, ref def_fpu, ref def_thumb)
+
+let pic_code = ref false
+
+let farch spec =
+  arch := (match spec with
+             "armv4" when abi <> EABI_VFP   -> ARMv4
+           | "armv5" when abi <> EABI_VFP   -> ARMv5
+           | "armv5te" when abi <> EABI_VFP -> ARMv5TE
+           | "armv6" when abi <> EABI_VFP   -> ARMv6
+           | "armv6t2" when abi <> EABI_VFP -> ARMv6T2
+           | "armv7"                        -> ARMv7
+           | spec -> raise (Arg.Bad spec))
+
+let ffpu spec =
+  fpu := (match spec with
+            "soft" when abi <> EABI_VFP     -> Soft
+          | "vfpv3-d16" when abi = EABI_VFP -> VFPv3_D16
+          | "vfpv3" when abi = EABI_VFP     -> VFPv3
+          | spec -> raise (Arg.Bad spec))
+
+let command_line_options =
+  [ "-farch", Arg.String farch,
+      "<arch>  Select the ARM target architecture"
+      ^ " (default: " ^ (string_of_arch !arch) ^ ")";
+    "-ffpu", Arg.String ffpu,
+      "<fpu>  Select the floating-point hardware"
+      ^ " (default: " ^ (string_of_fpu !fpu) ^ ")";
+    "-fPIC", Arg.Set pic_code,
+      " Generate position-independent machine code";
+    "-fno-PIC", Arg.Clear pic_code,
+      " Generate position-dependent machine code";
+    "-fthumb", Arg.Set thumb,
+      " Enable Thumb/Thumb-2 code generation"
+      ^ (if !thumb then " (default)" else "");
+    "-fno-thumb", Arg.Clear thumb,
+      " Disable Thumb/Thumb-2 code generation"
+      ^ (if not !thumb then " (default" else "")]
 
 (* Addressing modes *)
 
@@ -37,6 +110,14 @@ type specific_operation =
     Ishiftarith of arith_operation * int
   | Ishiftcheckbound of int
   | Irevsubimm of int
+  | Imuladd     (* multiply and add *)
+  | Imulsub     (* multiply and subtract *)
+  | Inegmulf    (* floating-point negate and multiply *)
+  | Imuladdf    (* floating-point multiply and add *)
+  | Inegmuladdf (* floating-point negate, multiply and add *)
+  | Imulsubf    (* floating-point multiply and subtract *)
+  | Inegmulsubf (* floating-point negate, multiply and subtract *)
+  | Isqrtf      (* floating-point square root *)
 
 and arith_operation =
     Ishiftadd
@@ -51,6 +132,10 @@ let size_addr = 4
 let size_int = 4
 let size_float = 8
 
+(* Behavior of division *)
+
+let division_crashes_on_overflow = false
+
 (* Operations on addressing modes *)
 
 let identity_addressing = Iindexed 0
@@ -84,3 +169,56 @@ let print_specific_operation printreg op ppf arg =
       fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1)
   | Irevsubimm n ->
       fprintf ppf "%i %s %a" n "-" printreg arg.(0)
+  | Imuladd ->
+      fprintf ppf "(%a * %a) + %a"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Imulsub ->
+      fprintf ppf "-(%a * %a) + %a"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmulf ->
+      fprintf ppf "-f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+  | Imuladdf ->
+      fprintf ppf "%a +f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmuladdf ->
+      fprintf ppf "%a -f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Imulsubf ->
+      fprintf ppf "(-f %a) +f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Inegmulsubf ->
+      fprintf ppf "(-f %a) -f (%a *f %a)"
+        printreg arg.(0)
+        printreg arg.(1)
+        printreg arg.(2)
+  | Isqrtf ->
+      fprintf ppf "sqrtf %a"
+        printreg arg.(0)
+
+(* Recognize immediate operands *)
+
+(* Immediate operands are 8-bit immediate values, zero-extended,
+   and rotated right by 0 ... 30 bits.
+   In Thumb/Thumb-2 mode we utilize 26 ... 30. *)
+
+let is_immediate n =
+  let n = ref n in
+  let s = ref 0 in
+  let m = if !thumb then 24 else 30 in
+  while (!s <= m && Int32.logand !n 0xffl <> !n) do
+    n := Int32.logor (Int32.shift_right_logical !n 2) (Int32.shift_left !n 30);
+    s := !s + 2
+  done;
+  !s <= m

diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
index cfcb0c94fbdc2faa465929e92f8094cd39c034f3..846ee4ae3b70c03f138d53d8d8c54e7020903f88 100644 (file)
--- a/asmcomp/arm/emit.mlp
+++ b/asmcomp/arm/emit.mlp
@@ -1,12 +1,13 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  Benedikt Meurer, University of Siegen              *)
 (*                                                                     *)
-(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
+(*    Copyright 1998 Institut National de Recherche en Informatique    *)
+(*    et en Automatique. Copyright 2012 Benedikt Meurer. All rights    *)
+(*    reserved.  This file is distributed  under the terms of the Q    *)
+(*    Public License version 1.0.                                      *)
 (*                                                                     *)
 (***********************************************************************)
 
@@ -33,16 +34,28 @@ let fastcode_flag = ref true
 let emit_label lbl =
   emit_string ".L"; emit_int lbl
 
-(* Output a symbol *)
+let emit_data_label lbl =
+  emit_string ".Ld"; emit_int lbl
+
+(* Symbols *)
 
 let emit_symbol s =
   Emitaux.emit_symbol '$' s
 
+let emit_call s =
+  if !Clflags.dlcode || !pic_code
+  then `bl     {emit_symbol s}(PLT)`
+  else `bl     {emit_symbol s}`
+
+let emit_jump s =
+  if !Clflags.dlcode || !pic_code
+  then `b      {emit_symbol s}(PLT)`
+  else `b      {emit_symbol s}`
+
 (* Output a pseudo-register *)
 
-let emit_reg r =
-  match r.loc with
-  | Reg r -> emit_string (register_name r)
+let emit_reg = function
+    {loc = Reg r} -> emit_string (register_name r)
   | _ -> fatal_error "Emit_arm.emit_reg"
 
 (* Layout of the stack frame *)
@@ -53,14 +66,23 @@ let frame_size () =
   let sz =
     !stack_offset +
     4 * num_stack_slots.(0) +
+    8 * num_stack_slots.(1) +
+    8 * num_stack_slots.(2) +
     (if !contains_calls then 4 else 0)
   in Misc.align sz 8
 
 let slot_offset loc cl =
   match loc with
-    Incoming n -> frame_size() + n
-  | Local n -> !stack_offset + n * 4
-  | Outgoing n -> n
+    Incoming n ->
+      assert (n >= 0);
+      frame_size() + n
+  | Local n ->
+      if cl = 0
+      then !stack_offset + n * 4
+      else !stack_offset + num_stack_slots.(0) * 4 + n * 8
+  | Outgoing n ->
+      assert (n >= 0);
+      n
 
 (* Output a stack reference *)
 
@@ -79,20 +101,13 @@ let emit_addressing addr r n =
 
 (* Record live pointers at call points *)
 
-type frame_descr =
-  { fd_lbl: int;                        (* Return address *)
-    fd_frame_size: int;                 (* Size of stack frame *)
-    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
-
-let frame_descriptors = ref([] : frame_descr list)
-
-let record_frame live =
+let record_frame_label live dbg =
   let lbl = new_label() in
   let live_offset = ref [] in
   Reg.Set.iter
     (function
         {typ = Addr; loc = Reg r} ->
-          live_offset := (r lsl 1) + 1 :: !live_offset
+          live_offset := ((r lsl 1) + 1) :: !live_offset
       | {typ = Addr; loc = Stack s} as reg ->
           live_offset := slot_offset s (register_class reg) :: !live_offset
       | _ -> ())
@@ -100,18 +115,57 @@ let record_frame live =
   frame_descriptors :=
     { fd_lbl = lbl;
       fd_frame_size = frame_size();
-      fd_live_offset = !live_offset } :: !frame_descriptors;
-  `{emit_label lbl}:`
-
-let emit_frame fd =
-  `    .word   {emit_label fd.fd_lbl} + 4\n`;
-  `    .short  {emit_int fd.fd_frame_size}\n`;
-  `    .short  {emit_int (List.length fd.fd_live_offset)}\n`;
-  List.iter
-    (fun n ->
-      `        .short  {emit_int n}\n`)
-    fd.fd_live_offset;
-  `    .align  2\n`
+      fd_live_offset = !live_offset;
+      fd_debuginfo = dbg } :: !frame_descriptors;
+  lbl
+
+let record_frame live dbg =
+  let lbl = record_frame_label live dbg in `{emit_label lbl}:`
+
+(* Record calls to the GC -- we've moved them out of the way *)
+
+type gc_call =
+  { gc_lbl: label;                      (* Entry label *)
+    gc_return_lbl: label;               (* Where to branch after GC *)
+    gc_frame_lbl: label }               (* Label of frame descriptor *)
+
+let call_gc_sites = ref ([] : gc_call list)
+
+let emit_call_gc gc =
+  `{emit_label gc.gc_lbl}:     {emit_call "caml_call_gc"}\n`;
+  `{emit_label gc.gc_frame_lbl}:       b       {emit_label gc.gc_return_lbl}\n`
+
+(* Record calls to caml_ml_array_bound_error.
+   In debug mode, we maintain one call to caml_ml_array_bound_error
+   per bound check site. Otherwise, we can share a single call. *)
+
+type bound_error_call =
+  { bd_lbl: label;                    (* Entry label *)
+    bd_frame_lbl: label }             (* Label of frame descriptor *)
+
+let bound_error_sites = ref ([] : bound_error_call list)
+
+let bound_error_label dbg =
+  if !Clflags.debug || !bound_error_sites = [] then begin
+    let lbl_bound_error = new_label() in
+    let lbl_frame = record_frame_label Reg.Set.empty dbg in
+    bound_error_sites :=
+      { bd_lbl = lbl_bound_error;
+        bd_frame_lbl = lbl_frame } :: !bound_error_sites;
+    lbl_bound_error
+  end else begin
+    let bd = List.hd !bound_error_sites in bd.bd_lbl
+  end
+
+let emit_call_bound_error bd =
+  `{emit_label bd.bd_lbl}:     {emit_call "caml_ml_array_bound_error"}\n`;
+  `{emit_label bd.bd_frame_lbl}:\n`
+
+(* Negate a comparison *)
+
+let negate_integer_comparison = function
+    Isigned cmp   -> Isigned(negate_comparison cmp)
+  | Iunsigned cmp -> Iunsigned(negate_comparison cmp)
 
 (* Names of various instructions *)
 
@@ -121,22 +175,13 @@ let name_for_comparison = function
   | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls"
   | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi"
 
-let name_for_float_comparison cmp neg =
-  match cmp with
-    Ceq -> if neg then "ne" else "eq"
-  | Cne -> if neg then "eq" else "ne"
-  | Cle -> if neg then "hi" else "ls"
-  | Cge -> if neg then "lt" else "ge"
-  | Clt -> if neg then "pl" else "mi"
-  | Cgt -> if neg then "le" else "gt"
-
 let name_for_int_operation = function
     Iadd -> "add"
   | Isub -> "sub"
   | Imul -> "mul"
-  | Iand  -> "and"
-  | Ior   -> "orr"
-  | Ixor  -> "eor"
+  | Iand -> "and"
+  | Ior  -> "orr"
+  | Ixor -> "eor"
   | _ -> assert false
 
 let name_for_shift_operation = function
@@ -145,60 +190,54 @@ let name_for_shift_operation = function
   | Iasr -> "asr"
   | _ -> assert false
 
-let name_for_shift_int_operation = function
-    Ishiftadd -> "add"
-  | Ishiftsub -> "sub"
-  | Ishiftsubrev -> "rsb"
-
-(* Recognize immediate operands *)
-
-(* Immediate operands are 8-bit immediate values, zero-extended, and rotated
-   right by 0, 2, 4, ... 30 bits.
-   We check only with 8-bit values shifted left 0 to 24 bits. *)
-
-let rec is_immed n shift =
-  shift <= 24 &&
-  (Nativeint.logand n (Nativeint.shift_left (Nativeint.of_int 0xFF) shift) = n
-   || is_immed n (shift + 2))
-
-let is_immediate n = is_immed n 0
-
 (* General functional to decompose a non-immediate integer constant
-   into 8-bit chunks shifted left 0 ... 24 bits *)
+   into 8-bit chunks shifted left 0 ... 30 bits. *)
 
 let decompose_intconst n fn =
   let i = ref n in
   let shift = ref 0 in
   let ninstr = ref 0 in
-  while !i <> 0n do
-    if Nativeint.to_int (Nativeint.shift_right !i !shift) land 3 = 0 then
+  while !i <> 0l do
+    if Int32.logand (Int32.shift_right !i !shift) 3l = 0l then
       shift := !shift + 2
     else begin
-      let mask = Nativeint.shift_left 0xFFn !shift in
-      let bits = Nativeint.logand !i mask in
-      fn bits;
+      let bits = Int32.logand !i (Int32.shift_left 0xffl !shift) in
+      i := Int32.sub !i bits;
       shift := !shift + 8;
-      i := Nativeint.sub !i bits;
-      incr ninstr
+      incr ninstr;
+      fn bits
     end
   done;
   !ninstr
 
 (* Load an integer constant into a register *)
 
-let emit_intconst r n =
-  let nr = Nativeint.lognot n in
+let emit_intconst dst n =
+  let nr = Int32.lognot n in
   if is_immediate n then begin
-    `  mov     {emit_reg r}, #{emit_nativeint n}\n`; 1
+    (* Use movs here to enable 16-bit T1 encoding *)
+    `  movs    {emit_reg dst}, #{emit_int32 n}\n`; 1
   end else if is_immediate nr then begin
-    `  mvn     {emit_reg r}, #{emit_nativeint nr}\n`; 1
+    `  mvn     {emit_reg dst}, #{emit_int32 nr}\n`; 1
+  end else if !arch > ARMv6 then begin
+    let nl = Int32.logand 0xffffl n in
+    let nh = Int32.logand 0xffffl (Int32.shift_right_logical n 16) in
+    if nh = 0l then begin
+      `        movw    {emit_reg dst}, #{emit_int32 nl}\n`; 1
+    end else if Int32.logand nl 0xffl = nl then begin
+      `        movs    {emit_reg dst}, #{emit_int32 nl}\n`;
+      `        movt    {emit_reg dst}, #{emit_int32 nh}\n`; 2
+    end else begin
+      `        movw    {emit_reg dst}, #{emit_int32 nl}\n`;
+      `        movt    {emit_reg dst}, #{emit_int32 nh}\n`; 2
+    end
   end else begin
     let first = ref true in
     decompose_intconst n
       (fun bits ->
         if !first
-        then ` mov     {emit_reg r}, #{emit_nativeint bits} @ {emit_nativeint n}\n`
-        else ` add     {emit_reg r}, {emit_reg r}, #{emit_nativeint bits}\n`;
+        then ` mov     {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n`
+        else ` add     {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`;
         first := false)
   end
 
@@ -206,46 +245,105 @@ let emit_intconst r n =
 
 let emit_stack_adjustment instr n =
   if n <= 0 then 0 else
-    decompose_intconst (Nativeint.of_int n)
+    decompose_intconst (Int32.of_int n)
       (fun bits ->
-        `      {emit_string instr}     sp, sp, #{emit_nativeint bits}\n`)
+        `      {emit_string instr}     sp, sp, #{emit_int32 bits}\n`)
 
 (* Name of current function *)
 let function_name = ref ""
 (* Entry point for tail recursive calls *)
 let tailrec_entry_point = ref 0
-(* Table of symbols referenced *)
-let symbol_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
-(* Table of floating-point literals *)
-let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t)
-(* Total space (in word) occupied by pending literals *)
+(* Pending floating-point literals *)
+let float_literals = ref ([] : (string * label) list)
+(* Pending relative references to the global offset table *)
+let gotrel_literals = ref ([] : (label * label) list)
+(* Pending symbol literals *)
+let symbol_literals = ref ([] : (string * label) list)
+(* Total space (in words) occupied by pending literals *)
 let num_literals = ref 0
 
-(* Label a symbol or float constant *)
-let label_constant tbl s size =
+(* Label a floating-point literal *)
+let float_literal f =
   try
-    Hashtbl.find tbl s
+    List.assoc f !float_literals
   with Not_found ->
     let lbl = new_label() in
-    Hashtbl.add tbl s lbl;
-    num_literals := !num_literals + size;
+    num_literals := !num_literals + 2;
+    float_literals := (f, lbl) :: !float_literals;
     lbl
 
-(* Emit all pending constants *)
-
-let emit_constants () =
-  Hashtbl.iter
-    (fun s lbl ->
-      `{emit_label lbl}:        .word   {emit_symbol s}\n`)
-    symbol_constants;
-  Hashtbl.iter
-    (fun s lbl ->
-      `{emit_label lbl}:        .double {emit_string s}\n`)
-    float_constants;
-  Hashtbl.clear symbol_constants;
-  Hashtbl.clear float_constants;
+(* Label a GOTREL literal *)
+let gotrel_literal l =
+  let lbl = new_label() in
+  num_literals := !num_literals + 1;
+  gotrel_literals := (l, lbl) :: !gotrel_literals;
+  lbl
+
+(* Label a symbol literal *)
+let symbol_literal s =
+  try
+    List.assoc s !symbol_literals
+  with Not_found ->
+    let lbl = new_label() in
+    num_literals := !num_literals + 1;
+    symbol_literals := (s, lbl) :: !symbol_literals;
+    lbl
+
+(* Emit all pending literals *)
+let emit_literals() =
+  if !float_literals <> [] then begin
+    `  .align  3\n`;
+    List.iter
+      (fun (f, lbl) ->
+        `{emit_label lbl}:     .double {emit_string f}\n`)
+      !float_literals;
+    float_literals := []
+  end;
+  if !symbol_literals <> [] then begin
+    let offset = if !thumb then 4 else 8 in
+    let suffix = if !pic_code then "(GOT)" else "" in
+    `  .align  2\n`;
+    List.iter
+      (fun (l, lbl) ->
+        `{emit_label lbl}:     .word   _GLOBAL_OFFSET_TABLE_-({emit_label l}+{emit_int offset})\n`)
+      !gotrel_literals;
+    List.iter
+      (fun (s, lbl) ->
+        `{emit_label lbl}:     .word   {emit_symbol s}{emit_string suffix}\n`)
+      !symbol_literals;
+    gotrel_literals := [];
+    symbol_literals := []
+  end;
   num_literals := 0
 
+(* Emit code to load the address of a symbol *)
+
+let emit_load_symbol_addr dst s =
+  if !pic_code then begin
+    let lbl_pic = new_label() in
+    let lbl_got = gotrel_literal lbl_pic in
+    let lbl_sym = symbol_literal s in
+    (* Both r3 and r12 are marked as clobbered in PIC mode (cf. proc.ml),
+       so use r12 as temporary scratch register unless the destination is
+       r12, then we use r3 instead. *)
+    let tmp = if dst.loc = Reg 8 (*r12*)
+              then phys_reg 3 (*r3*)
+              else phys_reg 8 (*r12*) in
+    `  ldr     {emit_reg tmp}, {emit_label lbl_got}\n`;
+    `  ldr     {emit_reg dst}, {emit_label lbl_sym}\n`;
+    `{emit_label lbl_pic}:     add     {emit_reg tmp}, pc, {emit_reg tmp}\n`;
+    `  ldr     {emit_reg dst}, [{emit_reg tmp}, {emit_reg dst}] @ {emit_symbol s}\n`;
+    4
+  end else if !arch > ARMv6 && not !Clflags.dlcode && !fastcode_flag then begin
+    `  movw    {emit_reg dst}, #:lower16:{emit_symbol s}\n`;
+    `  movt    {emit_reg dst}, #:upper16:{emit_symbol s}\n`;
+    2
+  end else begin
+    let lbl = symbol_literal s in
+    `  ldr     {emit_reg dst}, {emit_label lbl} @ {emit_symbol s}\n`;
+    1
+  end
+
 (* Output the assembly code for an instruction *)
 
 let emit_instr i =
@@ -254,40 +352,76 @@ let emit_instr i =
     | Lop(Imove | Ispill | Ireload) ->
         let src = i.arg.(0) and dst = i.res.(0) in
         if src.loc = dst.loc then 0 else begin
-          match (src, dst) with
-            {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} ->
-              `        mov     {emit_reg dst}, {emit_reg src}\n`; 1
-          | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} ->
-              `        str     {emit_reg src}, {emit_stack dst}\n`; 1
-          | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} ->
-              `        ldr     {emit_reg dst}, {emit_stack src}\n`; 1
+          begin match (src, dst) with
+            {loc = Reg _; typ = Float}, {loc = Reg _} ->
+              `        fcpyd   {emit_reg dst}, {emit_reg src}\n`
+          | {loc = Reg _}, {loc = Reg _} ->
+              `        mov     {emit_reg dst}, {emit_reg src}\n`
+          | {loc = Reg _; typ = Float}, _ ->
+              `        fstd    {emit_reg src}, {emit_stack dst}\n`
+          | {loc = Reg _}, _ ->
+              `        str     {emit_reg src}, {emit_stack dst}\n`
+          | {typ = Float}, _ ->
+              `        fldd    {emit_reg dst}, {emit_stack src}\n`
           | _ ->
-              assert false
+              `        ldr     {emit_reg dst}, {emit_stack src}\n`
+          end; 1
         end
     | Lop(Iconst_int n) ->
-        emit_intconst i.res.(0) n
-    | Lop(Iconst_float s) ->
-        let bits = Int64.bits_of_float (float_of_string s) in
-        let high_bits = Int64.to_nativeint (Int64.shift_right_logical bits 32)
-        and low_bits = Int64.to_nativeint bits in
-        if is_immediate low_bits && is_immediate high_bits then begin
-          `    mov     {emit_reg i.res.(0)}, #{emit_nativeint low_bits} @ {emit_string s}\n`;
-          `    mov     {emit_reg i.res.(1)}, #{emit_nativeint high_bits}\n`;
-          2
+        emit_intconst i.res.(0) (Nativeint.to_int32 n)
+    | Lop(Iconst_float f) when !fpu = Soft ->
+        `      @ {emit_string f}\n`;
+        let bits = Int64.bits_of_float (float_of_string f) in
+        let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32)
+        and low_bits = Int64.to_int32 bits in
+        if is_immediate low_bits || is_immediate high_bits then begin
+          let ninstr_low = emit_intconst i.res.(0) low_bits
+          and ninstr_high = emit_intconst i.res.(1) high_bits in
+          ninstr_low + ninstr_high
         end else begin
-          let lbl = label_constant float_constants s 2 in
-          `    ldr     {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`;
+          let lbl = float_literal f in
+          `    ldr     {emit_reg i.res.(0)}, {emit_label lbl}\n`;
           `    ldr     {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`;
           2
         end
+    | Lop(Iconst_float f) ->
+        let encode imm =
+          let sg = Int64.to_int (Int64.shift_right_logical imm 63) in
+          let ex = Int64.to_int (Int64.shift_right_logical imm 52) in
+          let ex = (ex land 0x7ff) - 1023 in
+          let mn = Int64.logand imm 0xfffffffffffffL in
+          if Int64.logand mn 0xffffffffffffL <> 0L || ex < -3 || ex > 4
+          then
+            None
+          else begin
+            let mn = Int64.to_int (Int64.shift_right_logical mn 48) in
+            if mn land 0x0f <> mn then
+              None
+            else
+              let ex = ((ex + 3) land 0x07) lxor 0x04 in
+              Some((sg lsl 7) lor (ex lsl 4) lor mn)
+          end in
+        begin match encode (Int64.bits_of_float (float_of_string f)) with
+          None ->
+            let lbl = float_literal f in
+            `  fldd    {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n`
+        | Some imm8 ->
+            `  fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n`
+        end; 1
     | Lop(Iconst_symbol s) ->
-        let lbl = label_constant symbol_constants s 1 in
-        `      ldr     {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_symbol s}\n`; 1
+        emit_load_symbol_addr i.res.(0) s
     | Lop(Icall_ind) ->
-        `      mov     lr, pc\n`;
-        `{record_frame i.live}  bx     {emit_reg i.arg.(0)}\n`; 2
+        if !arch >= ARMv5 then begin
+          `    blx     {emit_reg i.arg.(0)}\n`;
+          `{record_frame i.live i.dbg}\n`; 1
+        end else begin
+          `    mov     lr, pc\n`;
+          `    bx      {emit_reg i.arg.(0)}\n`;
+          `{record_frame i.live i.dbg}\n`; 2
+        end
     | Lop(Icall_imm s) ->
-        `{record_frame i.live}  bl      {emit_symbol s}\n`; 1
+        `      {emit_call s}\n`;
+        `{record_frame i.live i.dbg}\n`; 1
     | Lop(Itailcall_ind) ->
         let n = frame_size() in
         if !contains_calls then
@@ -303,17 +437,16 @@ let emit_instr i =
           if !contains_calls then
             `  ldr     lr, [sp, #{emit_int (n-4)}]\n`;
           let ninstr = emit_stack_adjustment "add" n in
-          `    b       {emit_symbol s}\n`;
+          `    {emit_jump s}\n`;
           2 + ninstr
         end
-    | Lop(Iextcall(s, alloc)) ->
-        if alloc then begin
-          let lbl = label_constant symbol_constants s 1 in
-          `    ldr     r12, {emit_label lbl} @ {emit_symbol s}\n`;
-          `{record_frame i.live}       bl      caml_c_call\n`; 2
-        end else begin
-          `    bl      {emit_symbol s}\n`; 1
-        end
+    | Lop(Iextcall(s, false)) ->
+        `      {emit_call s}\n`; 1
+    | Lop(Iextcall(s, true)) ->
+        let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in
+        `      {emit_call "caml_c_call"}\n`;
+        `{record_frame i.live i.dbg}\n`;
+        1 + ninstr
     | Lop(Istackoffset n) ->
         assert (n mod 8 = 0);
         let ninstr =
@@ -322,16 +455,28 @@ let emit_instr i =
           else emit_stack_adjustment "add" (-n) in
         stack_offset := !stack_offset + n;
         ninstr
-    | Lop(Iload((Double | Double_u), addr)) ->
-        let addr' = offset_addressing addr 4 in
-        if i.res.(0).loc <> i.arg.(0).loc then begin
-          `    ldr     {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`;
-          `    ldr     {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`
-        end else begin
-          `    ldr     {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`;
-          `    ldr     {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`
-        end;
-        2
+    | Lop(Iload(Single, addr)) when !fpu >= VFPv3_D16 ->
+        `      flds    s14, {emit_addressing addr i.arg 0}\n`;
+        `      fcvtds  {emit_reg i.res.(0)}, s14\n`; 2
+    | Lop(Iload((Double | Double_u), addr)) when !fpu = Soft ->
+        (* Use LDM or LDRD if possible *)
+        begin match i.res.(0), i.res.(1), addr with
+          {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0
+          when rt < rt2 ->
+            `  ldm     {emit_reg i.arg.(0)}, \{{emit_reg i.res.(0)}, {emit_reg i.res.(1)}}\n`; 1
+        | {loc = Reg rt}, {loc = Reg rt2}, addr
+          when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 ->
+            `  ldrd    {emit_reg i.res.(0)}, {emit_reg i.res.(1)}, {emit_addressing addr i.arg 0}\n`; 1
+        | _ ->
+            let addr' = offset_addressing addr 4 in
+            if i.res.(0).loc <> i.arg.(0).loc then begin
+              `        ldr     {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`;
+              `        ldr     {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`
+            end else begin
+              `        ldr     {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`;
+              `        ldr     {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`
+            end; 2
+        end
     | Lop(Iload(size, addr)) ->
         let r = i.res.(0) in
         let instr =
@@ -340,65 +485,114 @@ let emit_instr i =
           | Byte_signed -> "ldrsb"
           | Sixteen_unsigned -> "ldrh"
           | Sixteen_signed -> "ldrsh"
+          | Double
+          | Double_u -> "fldd"
           | _ (* 32-bit quantities *) -> "ldr" in
-        `      {emit_string    instr}     {emit_reg r}, {emit_addressing addr i.arg 0}\n`;
-        1
-    | Lop(Istore((Double | Double_u), addr)) ->
-        let addr' = offset_addressing addr 4 in
-        `      str     {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`;
-        `      str     {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`;
-        2
+        `      {emit_string instr}     {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1
+    | Lop(Istore(Single, addr)) when !fpu >= VFPv3_D16 ->
+        `      fcvtsd  s14, {emit_reg i.arg.(0)}\n`;
+        `      fsts    s14, {emit_addressing addr i.arg 1}\n`; 2
+    | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft ->
+        (* Use STM or STRD if possible *)
+        begin match i.arg.(0), i.arg.(1), addr with
+          {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0
+          when rt < rt2 ->
+            `  stm     {emit_reg i.arg.(2)}, \{{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}}\n`; 1
+        | {loc = Reg rt}, {loc = Reg rt2}, addr
+          when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 ->
+            `  strd    {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_addressing addr i.arg 2}\n`; 1
+        | _ ->
+            let addr' = offset_addressing addr 4 in
+            `  str     {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`;
+            `  str     {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2
+        end
     | Lop(Istore(size, addr)) ->
         let r = i.arg.(0) in
         let instr =
           match size with
-            Byte_unsigned | Byte_signed -> "strb"
-          | Sixteen_unsigned | Sixteen_signed -> "strh"
+            Byte_unsigned
+          | Byte_signed -> "strb"
+          | Sixteen_unsigned
+          | Sixteen_signed -> "strh"
+          | Double
+          | Double_u -> "fstd"
           | _ (* 32-bit quantities *) -> "str" in
-        `      {emit_string    instr}     {emit_reg r}, {emit_addressing addr i.arg 1}\n`;
-        1
+        `      {emit_string instr}     {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1
     | Lop(Ialloc n) ->
+        let lbl_frame = record_frame_label i.live i.dbg in
         if !fastcode_flag then begin
-          let ni = emit_intconst (phys_reg 8 (*r12*)) (Nativeint.of_int n) in
-          `    sub     alloc_ptr, alloc_ptr, r12\n`;
+          let lbl_redo = new_label() in
+          `{emit_label lbl_redo}:`;
+          let ninstr = decompose_intconst
+                         (Int32.of_int n)
+                         (fun i ->
+                           `   sub     alloc_ptr, alloc_ptr, #{emit_int32 i}\n`) in
           `    cmp     alloc_ptr, alloc_limit\n`;
-          `{record_frame i.live}       blcc    caml_call_gc\n`;
           `    add     {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
-          4 + ni
-        end else if n = 8 || n = 12 || n = 16 then begin
-          `{record_frame i.live}       bl      caml_alloc{emit_int ((n-4)/4)}\n`;
-          `    add     {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 2
+          let lbl_call_gc = new_label() in
+          `    bcc     {emit_label lbl_call_gc}\n`;
+          call_gc_sites :=
+            { gc_lbl = lbl_call_gc;
+              gc_return_lbl = lbl_redo;
+              gc_frame_lbl = lbl_frame } :: !call_gc_sites;
+          3 + ninstr
         end else begin
-          let ni = emit_intconst (phys_reg 8 (*r12*)) (Nativeint.of_int n) in
-          `{record_frame i.live}       bl      caml_allocN\n`;
-          `    add     {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
-          2 + ni
+          let ninstr =
+            begin match n with
+               8 -> `  {emit_call "caml_alloc1"}\n`; 1
+            | 12 -> `  {emit_call "caml_alloc2"}\n`; 1
+            | 16 -> `  {emit_call "caml_alloc3"}\n`; 1
+            |  _ -> let ninstr = emit_intconst (phys_reg 7) (Int32.of_int n) in
+                    `  {emit_call "caml_allocN"}\n`; 1 + ninstr
+            end in
+          `{emit_label lbl_frame}:     add     {emit_reg i.res.(0)}, alloc_ptr, #4\n`;
+          1 + ninstr
         end
     | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) ->
         let shift = name_for_shift_operation op in
         `      mov     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1
     | Lop(Iintop(Icomp cmp)) ->
-        let comp = name_for_comparison cmp in
+        let compthen = name_for_comparison cmp in
+        let compelse = name_for_comparison (negate_integer_comparison cmp) in
         `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-        `      mov     {emit_reg i.res.(0)}, #0\n`;
-        `      mov{emit_string comp}   {emit_reg i.res.(0)}, #1\n`; 3
-    | Lop(Iintop(Icheckbound)) ->
+        `      ite     {emit_string compthen}\n`;
+        `      mov{emit_string compthen}       {emit_reg i.res.(0)}, #1\n`;
+        `      mov{emit_string compelse}       {emit_reg i.res.(0)}, #0\n`; 4
+    | Lop(Iintop_imm(Icomp cmp, n)) ->
+        let compthen = name_for_comparison cmp in
+        let compelse = name_for_comparison (negate_integer_comparison cmp) in
+        `      cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
+        `      ite     {emit_string compthen}\n`;
+        `      mov{emit_string compthen}       {emit_reg i.res.(0)}, #1\n`;
+        `      mov{emit_string compelse}       {emit_reg i.res.(0)}, #0\n`; 4
+    | Lop(Iintop Icheckbound) ->
+        let lbl = bound_error_label i.dbg in
         `      cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-        `      blls    caml_ml_array_bound_error\n`; 2
+        `      bls     {emit_label lbl}\n`; 2
+    | Lop(Iintop_imm(Icheckbound, n)) ->
+        let lbl = bound_error_label i.dbg in
+        `      cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
+        `      bls     {emit_label lbl}\n`; 2
+    | Lop(Ispecific(Ishiftcheckbound shift)) ->
+        let lbl = bound_error_label i.dbg in
+        `      cmp     {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
+        `      bcs     {emit_label lbl}\n`; 2
     | Lop(Iintop op) ->
         let instr = name_for_int_operation op in
-        `      {emit_string    instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
+        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1
     | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *)
         let l = Misc.log2 n in
         let r = i.res.(0) in
         `      movs    {emit_reg r}, {emit_reg i.arg.(0)}\n`;
-        if n <= 256 then
+        if n <= 256 then begin
+          `    it      lt\n`;
           `    addlt   {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n`
-        else begin
+        end else begin
+          `    itt     lt\n`;
           `    addlt   {emit_reg r}, {emit_reg r}, #{emit_int n}\n`;
           `    sublt   {emit_reg r}, {emit_reg r}, #1\n`
         end;
-        `      mov     {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 4
+        `      mov     {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 5
     | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *)
         let l = Misc.log2 n in
         let a = i.arg.(0) in
@@ -409,40 +603,71 @@ let emit_instr i =
         `      mov     {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`;
         `      bpl     {emit_label lbl}\n`;
         `      cmp     {emit_reg r}, #0\n`;
+        `      it      ne\n`;
         `      subne   {emit_reg r}, {emit_reg r}, #{emit_int n}\n`;
-        `{emit_label lbl}:\n`; 6
+        `{emit_label lbl}:\n`; 7
     | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) ->
         let shift = name_for_shift_operation op in
         `      mov     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1
-    | Lop(Iintop_imm(Icomp cmp, n)) ->
-        let comp = name_for_comparison cmp in
-        `      cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
-        `      mov     {emit_reg i.res.(0)}, #0\n`;
-        `      mov{emit_string comp}   {emit_reg i.res.(0)}, #1\n`; 3
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-        `      cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
-        `      blls    caml_ml_array_bound_error\n`; 2
     | Lop(Iintop_imm(op, n)) ->
         let instr = name_for_int_operation op in
-        `      {emit_string    instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
-    | Lop(Inegf) -> (* argument and result in (r0, r1) *)
-        `      eor     r1, r1, #0x80000000\n`; 1
-    | Lop(Iabsf) -> (* argument and result in (r0, r1) *)
-        `      bic     r1, r1, #0x80000000\n`; 1
-    | Lop(Ifloatofint | Iintoffloat | Iaddf | Isubf | Imulf | Idivf) ->
-        assert false
+        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
+    | Lop(Iabsf | Inegf as op) when !fpu = Soft ->
+        let instr = (match op with
+                       Iabsf -> "bic"
+                     | Inegf -> "eor"
+                     | _     -> assert false) in
+        `      {emit_string instr}     {emit_reg i.res.(1)}, {emit_reg i.arg.(1)}, #0x80000000\n`; 1
+    | Lop(Iabsf | Inegf | Ispecific Isqrtf as op) ->
+        let instr = (match op with
+                       Iabsf            -> "fabsd"
+                     | Inegf            -> "fnegd"
+                     | Ispecific Isqrtf -> "fsqrtd"
+                     | _                -> assert false) in
+        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1
+    | Lop(Ifloatofint) ->
+        `      fmsr    s14, {emit_reg i.arg.(0)}\n`;
+        `      fsitod  {emit_reg i.res.(0)}, s14\n`; 2
+    | Lop(Iintoffloat) ->
+        `      ftosizd s14, {emit_reg i.arg.(0)}\n`;
+        `      fmrs    {emit_reg i.res.(0)}, s14\n`; 2
+    | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) ->
+        let instr = (match op with
+                       Iaddf              -> "faddd"
+                     | Isubf              -> "fsubd"
+                     | Imulf              -> "fmuld"
+                     | Idivf              -> "fdivd"
+                     | Ispecific Inegmulf -> "fnmuld"
+                     | _                  -> assert false) in
+        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+        1
+    | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) ->
+        let instr = (match op with
+                       Imuladdf    -> "fmacd"
+                     | Inegmuladdf -> "fnmacd"
+                     | Imulsubf    -> "fmscd"
+                     | Inegmulsubf -> "fnmscd"
+                     | _ -> assert false) in
+        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`;
+        1
     | Lop(Ispecific(Ishiftarith(op, shift))) ->
-        let instr = name_for_shift_int_operation op in
-        `      {emit_string    instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`;
+        let instr = (match op with
+                       Ishiftadd    -> "add"
+                     | Ishiftsub    -> "sub"
+                     | Ishiftsubrev -> "rsb") in
+        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`;
         if shift >= 0
         then `, lsl #{emit_int shift}\n`
         else `, asr #{emit_int (-shift)}\n`;
         1
-    | Lop(Ispecific(Ishiftcheckbound shift)) ->
-        `      cmp     {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`;
-        `      blcs    caml_ml_array_bound_error\n`; 2
     | Lop(Ispecific(Irevsubimm n)) ->
         `      rsb     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1
+    | Lop(Ispecific(Imuladd | Imulsub as op)) ->
+        let instr = (match op with
+                       Imuladd -> "mla"
+                     | Imulsub -> "mls"
+                     | _ -> assert false) in
+        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1
     | Lreloadretaddr ->
         let n = frame_size() in
         `      ldr     lr, [sp, #{emit_int(n-4)}]\n`; 1
@@ -458,29 +683,41 @@ let emit_instr i =
         begin match tst with
           Itruetest ->
             `  cmp     {emit_reg i.arg.(0)}, #0\n`;
-            `  bne     {emit_label lbl}\n`
+            `  bne     {emit_label lbl}\n`; 2
         | Ifalsetest ->
             `  cmp     {emit_reg i.arg.(0)}, #0\n`;
-            `  beq     {emit_label lbl}\n`
+            `  beq     {emit_label lbl}\n`; 2
         | Iinttest cmp ->
             `  cmp     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
             let comp = name_for_comparison cmp in
-            `  b{emit_string comp}     {emit_label lbl}\n`
+            `  b{emit_string comp}     {emit_label lbl}\n`; 2
         | Iinttest_imm(cmp, n) ->
             `  cmp     {emit_reg i.arg.(0)}, #{emit_int n}\n`;
             let comp = name_for_comparison cmp in
-            `  b{emit_string comp}     {emit_label lbl}\n`
+            `  b{emit_string comp}     {emit_label lbl}\n`; 2
         | Ifloattest(cmp, neg) ->
-            assert false
+            let comp = (match (cmp, neg) with
+                          (Ceq, false) | (Cne, true) -> "eq"
+                        | (Cne, false) | (Ceq, true) -> "ne"
+                        | (Clt, false) -> "cc"
+                        | (Clt, true)  -> "cs"
+                        | (Cle, false) -> "ls"
+                        | (Cle, true)  -> "hi"
+                        | (Cgt, false) -> "gt"
+                        | (Cgt, true)  -> "le"
+                        | (Cge, false) -> "ge"
+                        | (Cge, true)  -> "lt") in
+            `  fcmpd   {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
+            `  fmstat\n`;
+            `  b{emit_string comp}     {emit_label lbl}\n`; 3
         | Ioddtest ->
             `  tst     {emit_reg i.arg.(0)}, #1\n`;
-            `  bne     {emit_label lbl}\n`
+            `  bne     {emit_label lbl}\n`; 2
         | Ieventest ->
             `  tst     {emit_reg i.arg.(0)}, #1\n`;
-            `  beq     {emit_label lbl}\n`
-        end;
-        2
-  | Lcondbranch3(lbl0, lbl1, lbl2) ->
+            `  beq     {emit_label lbl}\n`; 2
+        end
+    | Lcondbranch3(lbl0, lbl1, lbl2) ->
         `      cmp     {emit_reg i.arg.(0)}, #1\n`;
         begin match lbl0 with
           None -> ()
@@ -495,107 +732,135 @@ let emit_instr i =
         | Some lbl -> `        bgt     {emit_label lbl}\n`
         end;
         4
-  | Lswitch jumptbl ->
-        `      ldr     pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`;
-        `      mov     r0, r0\n`;      (* nop *)
-        for i = 0 to Array.length jumptbl - 1 do
-          `    .word   {emit_label jumptbl.(i)}\n`
-        done;
-        2 + Array.length jumptbl
+    | Lswitch jumptbl ->
+        if !arch > ARMv6 && !thumb then begin
+          let lbl = new_label() in
+          `    tbh     [pc, {emit_reg i.arg.(0)}]\n`;
+          `{emit_label lbl}:`;
+          for i = 0 to Array.length jumptbl - 1 do
+            `  .short  ({emit_label jumptbl.(i)}-{emit_label lbl})/2\n`;
+          done;
+          `    .align  1\n`;
+          2 + Array.length jumptbl / 2
+        end else begin
+          if not !pic_code then begin
+            `  ldr     pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`;
+            `  nop\n`;
+            for i = 0 to Array.length jumptbl - 1 do
+              `        .word   {emit_label jumptbl.(i)}\n`
+            done
+          end else begin
+            (* Slightly slower, but position-independent *)
+            `  add     pc, pc, {emit_reg i.arg.(0)}, lsl #2\n`;
+            `  nop\n`;
+            for i = 0 to Array.length jumptbl - 1 do
+              `        b       {emit_label jumptbl.(i)}\n`
+            done
+          end;
+          2 + Array.length jumptbl
+        end
     | Lsetuptrap lbl ->
         `      bl      {emit_label lbl}\n`; 1
     | Lpushtrap ->
         stack_offset := !stack_offset + 8;
-        `      stmfd   sp!, \{trap_ptr, lr}\n`;
+        `      push    \{trap_ptr, lr}\n`;
         `      mov     trap_ptr, sp\n`; 2
     | Lpoptrap ->
-        `      ldmfd   sp!, \{trap_ptr, lr}\n`;
+        `      pop     \{trap_ptr, lr}\n`;
         stack_offset := !stack_offset - 8; 1
     | Lraise ->
-        `      mov     sp, trap_ptr\n`;
-        `      ldmfd   sp!, \{trap_ptr, pc}\n`; 2
+        if !Clflags.debug then begin
+          `    {emit_call "caml_raise_exn"}\n`;
+          `{record_frame Reg.Set.empty i.dbg}\n`; 1
+        end else begin
+          `    mov     sp, trap_ptr\n`;
+          `    pop     \{trap_ptr, pc}\n`; 2
+        end
 
 (* Emission of an instruction sequence *)
 
-let no_fallthrough = function
-    Lop(Itailcall_ind | Itailcall_imm _) -> true
-  | Lreturn -> true
-  | Lbranch _ -> true
-  | Lswitch _ -> true
-  | Lraise -> true
-  | _ -> false
-
 let rec emit_all ninstr i =
   if i.desc = Lend then () else begin
     let n = emit_instr i in
     let ninstr' = ninstr + n in
-    let limit = 511 - !num_literals in
-    if ninstr' >= limit - 64 && no_fallthrough i.desc then begin
-      emit_constants();
+    (* fldd can address up to +/-1KB, ldr can address up to +/-4KB *)
+    let limit = (if !fpu >= VFPv3_D16 && !float_literals <> []
+                 then 127
+                 else 511) in
+    let limit = limit - !num_literals in
+    if ninstr' >= limit - 64 && not(has_fallthrough i.desc) then begin
+      emit_literals();
       emit_all 0 i.next
-    end else
-    if ninstr' >= limit then begin
+    end else if !num_literals != 0 && ninstr' >= limit then begin
       let lbl = new_label() in
       `        b       {emit_label lbl}\n`;
-      emit_constants();
+      emit_literals();
       `{emit_label lbl}:\n`;
       emit_all 0 i.next
     end else
       emit_all ninstr' i.next
   end
 
+(* Emission of the profiling prelude *)
+
+let emit_profile() =
+  match Config.system with
+    "linux_eabi" | "linux_eabihf" ->
+      `        push    \{lr}\n`;
+      `        {emit_call "__gnu_mcount_nc"}\n`
+  | _ -> ()
+
 (* Emission of a function declaration *)
 
 let fundecl fundecl =
   function_name := fundecl.fun_name;
   fastcode_flag := fundecl.fun_fast;
   tailrec_entry_point := new_label();
+  float_literals := [];
+  gotrel_literals := [];
+  symbol_literals := [];
   stack_offset := 0;
-  Hashtbl.clear symbol_constants;
-  Hashtbl.clear float_constants;
+  call_gc_sites := [];
+  bound_error_sites := [];
   `    .text\n`;
   `    .align  2\n`;
-  `    .global {emit_symbol fundecl.fun_name}\n`;
+  `    .globl  {emit_symbol fundecl.fun_name}\n`;
+  if !arch > ARMv6 && !thumb then
+    `  .thumb\n`
+  else
+    `  .arm\n`;
+  `    .type   {emit_symbol fundecl.fun_name}, %function\n`;
   `{emit_symbol fundecl.fun_name}:\n`;
+  if !Clflags.gprofile then emit_profile();
   let n = frame_size() in
   ignore(emit_stack_adjustment "sub" n);
   if !contains_calls then
     `  str     lr, [sp, #{emit_int(n - 4)}]\n`;
   `{emit_label !tailrec_entry_point}:\n`;
   emit_all 0 fundecl.fun_body;
-  emit_constants()
+  emit_literals();
+  List.iter emit_call_gc !call_gc_sites;
+  List.iter emit_call_bound_error !bound_error_sites;
+  `    .type   {emit_symbol fundecl.fun_name}, %function\n`;
+  `    .size   {emit_symbol fundecl.fun_name}, .-{emit_symbol fundecl.fun_name}\n`
 
 (* Emission of data *)
 
 let emit_item = function
-    Cglobal_symbol s ->
-      `        .global {emit_symbol s}\n`;
-  | Cdefine_symbol s ->
-      `{emit_symbol s}:\n`
-  | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)}:\n`
-  | Cint8 n ->
-      `        .byte   {emit_int n}\n`
-  | Cint16 n ->
-      `        .short  {emit_int n}\n`
-  | Cint32 n ->
-      `        .word   {emit_nativeint n}\n`
-  | Cint n ->
-      `        .word   {emit_nativeint n}\n`
-  | Csingle f ->
-      emit_float32_directive ".long" f
-  | Cdouble f ->
-      emit_float64_split_directive ".long" f
-  | Csymbol_address s ->
-      `        .word   {emit_symbol s}\n`
-  | Clabel_address lbl ->
-      `        .word   {emit_label (100000 + lbl)}\n`
-  | Cstring s ->
-      emit_string_directive "  .ascii  " s
-  | Cskip n ->
-      if n > 0 then `  .space  {emit_int n}\n`
-  | Calign n ->
-      `        .align  {emit_int(Misc.log2 n)}\n`
+    Cglobal_symbol s -> `      .globl  {emit_symbol s}\n`;
+  | Cdefine_symbol s -> `{emit_symbol s}:\n`
+  | Cdefine_label lbl -> `{emit_data_label lbl}:\n`
+  | Cint8 n -> `       .byte   {emit_int n}\n`
+  | Cint16 n -> `      .short  {emit_int n}\n`
+  | Cint32 n -> `      .long   {emit_int32 (Nativeint.to_int32 n)}\n`
+  | Cint n -> `        .long   {emit_int32 (Nativeint.to_int32 n)}\n`
+  | Csingle f -> `     .single {emit_string f}\n`
+  | Cdouble f -> `     .double {emit_string f}\n`
+  | Csymbol_address s -> `     .word   {emit_symbol s}\n`
+  | Clabel_address lbl -> `    .word   {emit_data_label lbl}\n`
+  | Cstring s -> emit_string_directive "       .ascii  " s
+  | Cskip n -> if n > 0 then ` .space  {emit_int n}\n`
+  | Calign n -> `      .align  {emit_int(Misc.log2 n)}\n`
 
 let data l =
   `    .data\n`;
@@ -604,32 +869,62 @@ let data l =
 (* Beginning / end of an assembly file *)
 
 let begin_assembly() =
-  `trap_ptr     .req    r11\n`;
-  `alloc_ptr    .req    r8\n`;
-  `alloc_limit  .req    r10\n`;
+  `    .syntax unified\n`;
+  begin match !arch with
+  | ARMv4   -> `       .arch   armv4t\n`
+  | ARMv5   -> `       .arch   armv5t\n`
+  | ARMv5TE -> `       .arch   armv5te\n`
+  | ARMv6   -> `       .arch   armv6\n`
+  | ARMv6T2 -> `       .arch   armv6t2\n`
+  | ARMv7   -> `       .arch   armv7-a\n`
+  end;
+  begin match !fpu with
+    Soft      -> `     .fpu    softvfp\n`
+  | VFPv3_D16 -> `     .fpu    vfpv3-d16\n`
+  | VFPv3     -> `     .fpu    vfpv3\n`
+  end;
+  `trap_ptr    .req    r8\n`;
+  `alloc_ptr   .req    r10\n`;
+  `alloc_limit .req    r11\n`;
   let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
   `    .data\n`;
-  `    .global {emit_symbol lbl_begin}\n`;
+  `    .globl  {emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`;
   let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
   `    .text\n`;
-  `    .global {emit_symbol lbl_begin}\n`;
+  `    .globl  {emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`
 
 let end_assembly () =
   let lbl_end = Compilenv.make_symbol (Some "code_end") in
   `    .text\n`;
-  `    .global {emit_symbol lbl_end}\n`;
+  `    .globl  {emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   let lbl_end = Compilenv.make_symbol (Some "data_end") in
   `    .data\n`;
-  `    .global {emit_symbol lbl_end}\n`;
+  `    .globl  {emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
-  `    .word   0\n`;
+  `    .long   0\n`;
   let lbl = Compilenv.make_symbol (Some "frametable") in
-  `    .data\n`;
-  `    .global {emit_symbol lbl}\n`;
+  `    .globl  {emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
-  `    .word   {emit_int (List.length !frame_descriptors)}\n`;
-  List.iter emit_frame !frame_descriptors;
-  frame_descriptors := []
+  emit_frames
+    { efa_label = (fun lbl ->
+                       `       .type   {emit_label lbl}, %function\n`;
+                       `       .word   {emit_label lbl}\n`);
+      efa_16 = (fun n -> `     .short  {emit_int n}\n`);
+      efa_32 = (fun n -> `     .long   {emit_int32 n}\n`);
+      efa_word = (fun n -> `   .word   {emit_int n}\n`);
+      efa_align = (fun n -> `  .align  {emit_int(Misc.log2 n)}\n`);
+      efa_label_rel = (fun lbl ofs ->
+                           `   .word   {emit_label lbl} - . + {emit_int32 ofs}\n`);
+      efa_def_label = (fun lbl -> `{emit_label lbl}:\n`);
+      efa_string = (fun s -> emit_string_directive "   .asciz  " s) };
+  `    .type   {emit_symbol lbl}, %object\n`;
+  `    .size   {emit_symbol lbl}, .-{emit_symbol lbl}\n`;
+  begin match Config.system with
+    "linux_eabihf" | "linux_eabi" ->
+      (* Mark stack as non-executable *)
+      `        .section        .note.GNU-stack,\"\",%progbits\n`
+  | _ -> ()
+  end

diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml
index 06b085b4df6eb0e8445696ec228eef7eb1dc1ccf..aed2b01a7696438daf9685b99270065f40fdc332 100644 (file)
--- a/asmcomp/arm/proc.ml
+++ b/asmcomp/arm/proc.ml
@@ -1,12 +1,13 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  Benedikt Meurer, University of Siegen              *)
 (*                                                                     *)
-(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
+(*    Copyright 1998 Institut National de Recherche en Informatique    *)
+(*    et en Automatique. Copyright 2012 Benedikt Meurer. All rights    *)
+(*    reserved.  This file is distributed  under the terms of the Q    *)
+(*    Public License version 1.0.                                      *)
 (*                                                                     *)
 (***********************************************************************)
 
@@ -26,32 +27,56 @@ let word_addressed = false
 
 (* Registers available for register allocation *)
 
-(* Register map:
-    r0 - r3                     general purpose (not preserved by C)
-    r4 - r7                     general purpose (preserved)
-    r8                          allocation pointer (preserved)
-    r9                          platform register, usually reserved
-    r10                         allocation limit (preserved)
-    r11                         trap pointer (preserved)
-    r12                         general purpose (not preserved by C)
-    r13                         stack pointer
-    r14                         return address
-    r15                         program counter
+(* Integer register map:
+    r0 - r3               general purpose (not preserved)
+    r4 - r7               general purpose (preserved)
+    r8                    trap pointer (preserved)
+    r9                    platform register, usually reserved
+    r10                   allocation pointer (preserved)
+    r11                   allocation limit (preserved)
+    r12                   intra-procedural scratch register (not preserved)
+    r13                   stack pointer
+    r14                   return address
+    r15                   program counter
+   Floatinng-point register map (VFPv3):
+    d0 - d7               general purpose (not preserved)
+    d8 - d15              general purpose (preserved)
+    d16 - d31             generat purpose (not preserved), VFPv3 only
 *)
 
-let int_reg_name = [|
-  "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12"
-|]
+let int_reg_name =
+  [| "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12" |]
+
+let float_reg_name =
+  [| "d0";  "d1";  "d2";  "d3";  "d4";  "d5";  "d6";  "d7";
+     "d8";  "d9";  "d10"; "d11"; "d12"; "d13"; "d14"; "d15";
+     "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23";
+     "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |]
+
+(* We have three register classes:
+    0 for integer registers
+    1 for VFPv3-D16
+    2 for VFPv3
+   This way we can choose between VFPv3-D16 and VFPv3
+   at (ocamlopt) runtime using command line switches.
+*)
 
-let num_register_classes = 1
+let num_register_classes = 3
 
-let register_class r = assert (r.typ <> Float); 0
+let register_class r =
+  match (r.typ, !fpu) with
+    (Int | Addr), _  -> 0
+  | Float, VFPv3_D16 -> 1
+  | Float, _         -> 2
 
-let num_available_registers = [| 9 |]
+let num_available_registers =
+  [| 9; 16; 32 |]
 
-let first_available_register = [| 0 |]
+let first_available_register =
+  [| 0; 100; 100 |]
 
-let register_name r = int_reg_name.(r)
+let register_name r =
+  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
 
 let rotate_registers = true
 
@@ -59,25 +84,34 @@ let rotate_registers = true
 
 let hard_int_reg =
   let v = Array.create 9 Reg.dummy in
-  for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done;
+  for i = 0 to 8 do
+    v.(i) <- Reg.at_location Int (Reg i)
+  done;
+  v
+
+let hard_float_reg =
+  let v = Array.create 32 Reg.dummy in
+  for i = 0 to 31 do
+    v.(i) <- Reg.at_location Float (Reg(100 + i))
+  done;
   v
 
-let all_phys_regs = hard_int_reg
+let all_phys_regs =
+  Array.append hard_int_reg hard_float_reg
 
-let phys_reg n = all_phys_regs.(n)
+let phys_reg n =
+  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
 
 let stack_slot slot ty =
-  assert (ty <> Float);
   Reg.at_location ty (Stack slot)
 
 (* Calling conventions *)
 
-(* XXX float types have already been expanded into pairs of integers.
-   So we cannot align these floats.  See if that causes a problem. *)
-
-let calling_conventions first_int last_int make_stack arg =
+let calling_conventions
+    first_int last_int first_float last_float make_stack arg =
   let loc = Array.create (Array.length arg) Reg.dummy in
   let int = ref first_int in
+  let float = ref first_float in
   let ofs = ref 0 in
   for i = 0 to Array.length arg - 1 do
     match arg.(i).typ with
@@ -90,37 +124,86 @@ let calling_conventions first_int last_int make_stack arg =
           ofs := !ofs + size_int
         end
     | Float ->
-        assert false
+        assert (abi = EABI_VFP);
+        assert (!fpu >= VFPv3_D16);
+        if !float <= last_float then begin
+          loc.(i) <- phys_reg !float;
+          incr float
+        end else begin
+          ofs := Misc.align !ofs size_float;
+          loc.(i) <- stack_slot (make_stack !ofs) Float;
+          ofs := !ofs + size_float
+        end
   done;
-  (loc, Misc.align !ofs 8)
+  (loc, Misc.align !ofs 8)  (* keep stack 8-aligned *)
 
 let incoming ofs = Incoming ofs
 let outgoing ofs = Outgoing ofs
 let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
 
+(* OCaml calling convention:
+     first integer args in r0...r7
+     first float args in d0...d15 (EABI+VFP)
+     remaining args on stack.
+   Return values in r0...r7 or d0...d15. *)
+
 let loc_arguments arg =
-  calling_conventions 0 7 outgoing arg
+  calling_conventions 0 7 100 115 outgoing arg
 let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 0 7 incoming arg in loc
+  let (loc, _) = calling_conventions 0 7 100 115 incoming arg in loc
 let loc_results res =
-  let (loc, ofs) = calling_conventions 0 7 not_supported res in loc
+  let (loc, _) = calling_conventions 0 7 100 115 not_supported res in loc
+
+(* C calling convention:
+     first integer args in r0...r3
+     first float args in d0...d7 (EABI+VFP)
+     remaining args on stack.
+   Return values in r0...r1 or d0. *)
 
 let loc_external_arguments arg =
-  calling_conventions 0 3 outgoing arg
+  calling_conventions 0 3 100 107 outgoing arg
 let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 1 not_supported res in loc
+  let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc
 
 let loc_exn_bucket = phys_reg 0
 
 (* Registers destroyed by operations *)
 
-let destroyed_at_c_call =               (* r4-r7 preserved *)
-  Array.of_list(List.map phys_reg [0;1;2;3;8])
+let destroyed_at_alloc =            (* r0-r6, d0-d15 preserved *)
+  Array.of_list (List.map
+                   phys_reg
+                   [7;8;
+                    116;116;118;119;120;121;122;123;
+                    124;125;126;127;128;129;130;131])
+
+let destroyed_at_c_call =
+  Array.of_list (List.map
+                   phys_reg
+                   (match abi with
+                      EABI ->       (* r4-r7 preserved *)
+                        [0;1;2;3;8;
+                         100;101;102;103;104;105;106;107;
+                         108;109;110;111;112;113;114;115;
+                         116;116;118;119;120;121;122;123;
+                         124;125;126;127;128;129;130;131]
+                    | EABI_VFP ->   (* r4-r7, d8-d15 preserved *)
+                        [0;1;2;3;8;
+                         100;101;102;103;104;105;106;107;
+                         116;116;118;119;120;121;122;123;
+                         124;125;126;127;128;129;130;131]))
 
 let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
-  | Iop(Ialloc(_)) -> [|phys_reg 8|]    (* r12 destroyed *)
+    Iop(Icall_ind | Icall_imm _ )
+  | Iop(Iextcall(_, true)) ->
+      all_phys_regs
+  | Iop(Iextcall(_, false)) ->
+      destroyed_at_c_call
+  | Iop(Ialloc n) ->
+      destroyed_at_alloc
+  | Iop(Iconst_symbol _) when !pic_code ->
+      [|phys_reg 3; phys_reg 8|]  (* r3 and r12 destroyed *)
+  | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) ->
+      [|phys_reg 107|]            (* d7 (s14-s15) destroyed *)
   | _ -> [||]
 
 let destroyed_at_raise = all_phys_regs
@@ -128,15 +211,16 @@ let destroyed_at_raise = all_phys_regs
 (* Maximal register pressure *)
 
 let safe_register_pressure = function
-    Iextcall(_, _) -> 4
+    Iextcall(_, _) -> 5
   | _ -> 9
+
 let max_register_pressure = function
-    Iextcall(_, _) -> [| 4 |]
-  | _ -> [| 9 |]
+    Iextcall(_, _) -> [| 5; 9; 9 |]
+  | _ -> [| 9; 16; 32 |]
 
 (* Layout of the stack *)
 
-let num_stack_slots = [| 0 |]
+let num_stack_slots = [| 0; 0; 0 |]
 let contains_calls = ref false
 
 (* Calling the assembler *)
@@ -144,6 +228,3 @@ let contains_calls = ref false
 let assemble_file infile outfile =
   Ccomp.command (Config.asm ^ " -o " ^
                  Filename.quote outfile ^ " " ^ Filename.quote infile)
-
-open Clflags;;
-open Config;;

diff --git a/asmcomp/arm/reload.ml b/asmcomp/arm/reload.ml
index 65d8118179420333db91f5b7200029bcd4dd326e..c5b137abcf1567aface899221556b8e3a590b08d 100644 (file)
--- a/asmcomp/arm/reload.ml
+++ b/asmcomp/arm/reload.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml
index 8f49ad1eefc8080b376cbd640c61590e22644d99..4b47733f1f578541e37649b9bf49d73766293294 100644 (file)
--- a/asmcomp/arm/scheduling.ml
+++ b/asmcomp/arm/scheduling.ml
@@ -1,51 +1,79 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  Benedikt Meurer, University of Siegen              *)
 (*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
+(*    Copyright 1998 Institut National de Recherche en Informatique    *)
+(*    et en Automatique. Copyright 2012 Benedikt Meurer. All rights    *)
+(*    reserved.  This file is distributed  under the terms of the Q    *)
+(*    Public License version 1.0.                                      *)
 (*                                                                     *)
 (***********************************************************************)
 
 (* $Id$ *)
 
+open Arch
 open Mach
 
-(* Instruction scheduling for the Sparc *)
+(* Instruction scheduling for the ARM *)
 
-class scheduler = object
+class scheduler = object(self)
 
-inherit Schedgen.scheduler_generic
+inherit Schedgen.scheduler_generic as super
 
-(* Scheduling -- based roughly on the Strong ARM *)
+(* Scheduling -- based roughly on the ARM11 (ARMv6) *)
 
 method oper_latency = function
-    Ireload -> 2
-  | Iload(_, _) -> 2
-  | Iconst_symbol _ -> 2                (* turned into a load *)
-  | Iconst_float _ -> 2                 (* turned into a load *)
-  | Iintop(Imul) -> 3
-  | Iintop_imm(Imul, _) -> 3
-  (* No data available for floatops, let's make educated guesses *)
-  | Iaddf -> 3
-  | Isubf -> 3
-  | Imulf -> 5
-  | Idivf -> 15
+  (* Loads have a latency of two cycles in general *)
+    Iconst_symbol _
+  | Iconst_float _
+  | Iload(_, _)
+  | Ireload
+  | Ifloatofint       (* mcr/mrc count as memory access *)
+  | Iintoffloat -> 2
+  (* Multiplys have a latency of two cycles *)
+  | Iintop Imul
+  | Ispecific(Imuladd | Imulsub) -> 2
+  (* VFP instructions *)
+  | Iaddf
+  | Isubf
+  | Idivf
+  | Imulf | Ispecific Inegmulf
+  | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf)
+  | Ispecific Isqrtf
+  | Inegf | Iabsf when !fpu >= VFPv3_D16 -> 2
+  (* Everything else *)
   | _ -> 1
 
-(* Issue cycles.  Rough approximations *)
+method! is_checkbound = function
+    Ispecific(Ishiftcheckbound _) -> true
+  | op -> super#is_checkbound op
+
+(* Issue cycles. Rough approximations *)
 
 method oper_issue_cycles = function
     Ialloc _ -> 4
-  | Iintop(Icomp _) -> 3
-  | Iintop(Icheckbound) -> 2
-  | Iintop_imm(Idiv, _) -> 4
-  | Iintop_imm(Imod, _) -> 6
+  | Iintop(Ilsl | Ilsr | Iasr) -> 2
+  | Iintop(Icomp _)
   | Iintop_imm(Icomp _, _) -> 3
+  | Iintop(Icheckbound)
   | Iintop_imm(Icheckbound, _) -> 2
+  | Ispecific(Ishiftcheckbound _) -> 3
+  | Iintop_imm(Idiv, _) -> 4
+  | Iintop_imm(Imod, _) -> 6
+  | Iintop Imul
+  | Ispecific(Imuladd | Imulsub) -> 2
+  (* VFP instructions *)
+  | Iaddf
+  | Isubf -> 7
+  | Imulf
+  | Ispecific Inegmulf -> 9
+  | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> 17
+  | Idivf
+  | Ispecific Isqrtf -> 27
+  | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv3_D16 -> 4
+  (* Everything else *)
   | _ -> 1
 
 end

diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml
index 1574bf01e7b6f77d2be5051c91bc7f8c78bf62be..94d0367befbe332ebd3e2ed4fa586a0c2e74c974 100644 (file)
--- a/asmcomp/arm/selection.ml
+++ b/asmcomp/arm/selection.ml
@@ -1,12 +1,13 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                  Benedikt Meurer, University of Siegen              *)
 (*                                                                     *)
-(*  Copyright 1998 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
+(*    Copyright 1998 Institut National de Recherche en Informatique    *)
+(*    et en Automatique. Copyright 2012 Benedikt Meurer. All rights    *)
+(*    reserved.  This file is distributed  under the terms of the Q    *)
+(*    Public License version 1.0.                                      *)
 (*                                                                     *)
 (***********************************************************************)
 
@@ -14,41 +15,63 @@
 
 (* Instruction selection for the ARM processor *)
 
-open Misc
-open Cmm
-open Reg
 open Arch
-open Proc
+open Cmm
 open Mach
+open Misc
+open Proc
+open Reg
 
-(* Immediate operands are 8-bit immediate values, zero-extended, and rotated
-   right by 0, 2, 4, ... 30 bits.
-   To avoid problems with Caml's 31-bit arithmetic,
-   we check only with 8-bit values shifted left 0 to 22 bits. *)
-
-let rec is_immed n shift =
-  if shift > 22 then false
-  else if n land (0xFF lsl shift) = n then true
-  else is_immed n (shift + 2)
+let is_offset chunk n =
+  match chunk with
+  (* VFPv3 load/store have -1020 to 1020 *)
+    Single | Double | Double_u
+    when !fpu >= VFPv3_D16 ->
+      n >= -1020 && n <= 1020
+  (* ARM load/store byte/word have -4095 to 4095 *)
+  | Byte_unsigned | Byte_signed
+  | Thirtytwo_unsigned | Thirtytwo_signed
+  | Word | Single
+    when not !thumb ->
+      n >= -4095 && n <= 4095
+  (* Thumb-2 load/store have -255 to 4095 *)
+  | _ when !arch > ARMv6 && !thumb ->
+      n >= -255 && n <= 4095
+  (* Everything else has -255 to 255 *)
+  | _ ->
+      n >= -255 && n <= 255
 
-(* We have 12-bit + sign byte offsets for word accesses,
-   8-bit + sign word offsets for float accesses,
-   and 8-bit + sign byte offsets for bytes and shorts.
-   Use lowest common denominator. *)
+let is_intconst = function
+    Cconst_int _ -> true
+  | _ -> false
 
-let is_offset n = n < 256 && n > -256
+(* Special constraints on operand and result registers *)
 
-let is_intconst = function Cconst_int n -> true | _ -> false
+exception Use_default
 
-(* Soft emulation of float comparisons *)
+let r1 = phys_reg 1
 
-let float_comparison_function = function
-  | Ceq -> "__eqdf2"
-  | Cne -> "__nedf2"
-  | Clt -> "__ltdf2"
-  | Cle -> "__ledf2"
-  | Cgt -> "__gtdf2"
-  | Cge -> "__gedf2"
+let pseudoregs_for_operation op arg res =
+  match op with
+  (* For mul rd,rm,rs and mla rd,rm,rs,ra (pre-ARMv6) the registers rm
+     and rd must be different. We deal with this by pretending that rm
+     is also a result of the mul / mla operation. *)
+    Iintop Imul | Ispecific Imuladd when !arch < ARMv6 ->
+      (arg, [| res.(0); arg.(0) |])
+  (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *)
+  | Iabsf | Inegf when !fpu = Soft ->
+      ([|res.(0); arg.(1)|], res)
+  (* VFPv3 Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *)
+  | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) ->
+      let arg' = Array.copy arg in
+      arg'.(0) <- res.(0);
+      (arg', res)
+  (* We use __aeabi_idivmod for Cmodi only, and hence we care only
+     for the remainder in r1, so fix up the destination register. *)
+  | Iextcall("__aeabi_idivmod", false) ->
+      (arg, [|r1|])
+  (* Other instructions are regular *)
+  | _ -> raise Use_default
 
 (* Instruction selection *)
 class selector = object(self)
@@ -56,23 +79,32 @@ class selector = object(self)
 inherit Selectgen.selector_generic as super
 
 method! regs_for tyv =
-  (* Expand floats into pairs of integer registers *)
-  let nty = Array.length tyv in
-  let rec expand i =
-    if i >= nty then [] else begin
-      match tyv.(i) with
-      | Float -> Int :: Int :: expand (i+1)
-      | ty -> ty :: expand (i+1)
-    end in
-  Reg.createv (Array.of_list (expand 0))
+  Reg.createv (if !fpu = Soft then begin
+                 (* Expand floats into pairs of integer registers *)
+                 let rec expand = function
+                   [] -> []
+                 | Float :: tyl -> Int :: Int :: expand tyl
+                 | ty :: tyl -> ty :: expand tyl in
+                 Array.of_list (expand (Array.to_list tyv))
+               end else begin
+                 tyv
+               end)
 
 method is_immediate n =
-  n land 0xFF = n || is_immed n 2
+  is_immediate (Int32.of_int n)
+
+method! is_simple_expr = function
+  (* inlined floating-point ops are simple if their arguments are *)
+  | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv3_D16 ->
+      List.for_all self#is_simple_expr args
+  | e -> super#is_simple_expr e
 
-method select_addressing = function
-    Cop(Cadda, [arg; Cconst_int n]) when is_offset n ->
+method select_addressing chunk = function
+  | Cop(Cadda, [arg; Cconst_int n])
+    when is_offset chunk n ->
       (Iindexed n, arg)
-  | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) when is_offset n ->
+  | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])])
+    when is_offset chunk n ->
       (Iindexed n, Cop(Cadda, [arg1; arg2]))
   | arg ->
       (Iindexed 0, arg)
@@ -91,109 +123,146 @@ method select_shift_arith op shiftop shiftrevop args =
   | [Cop(Casr, [arg1; Cconst_int n]); arg2]
     when n > 0 && n < 32 && not(is_intconst arg1) ->
       (Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1])
-  | _ ->
-      super#select_operation op args
+  | args ->
+      begin match super#select_operation op args with
+      (* Recognize multiply and add *)
+        (Iintop Iadd, [Cop(Cmuli, args); arg3])
+      | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args ->
+          begin match self#select_operation Cmuli args with
+            (Iintop Imul, [arg1; arg2]) ->
+              (Ispecific Imuladd, [arg1; arg2; arg3])
+          | _ -> op_args
+          end
+      (* Recognize multiply and subtract *)
+      | (Iintop Isub, [arg3; Cop(Cmuli, args)]) as op_args
+        when !arch > ARMv6 ->
+          begin match self#select_operation Cmuli args with
+            (Iintop Imul, [arg1; arg2]) ->
+              (Ispecific Imulsub, [arg1; arg2; arg3])
+          | _ -> op_args
+          end
+      | op_args -> op_args
+      end
 
 method! select_operation op args =
-  match op with
-    Cadda | Caddi ->
-      begin match args with
-        [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) ->
-          (Iintop_imm(Isub, -n), [arg1])
-      | _ ->
-          self#select_shift_arith op Ishiftadd Ishiftadd args
-      end
-  | Csuba | Csubi ->
-      begin match args with
-        [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) ->
-          (Iintop_imm(Iadd, -n), [arg1])
-      | [Cconst_int n; arg2] when self#is_immediate n ->
-          (Ispecific(Irevsubimm n), [arg2])
-      | _ ->
-          self#select_shift_arith op Ishiftsub Ishiftsubrev args
-      end
-  | Cmuli ->                    (* no multiply immediate *)
+  match (op, args) with
+  (* Recognize special shift arithmetic *)
+    ((Cadda | Caddi), [arg; Cconst_int n])
+    when n < 0 && self#is_immediate (-n) ->
+      (Iintop_imm(Isub, -n), [arg])
+  | ((Cadda | Caddi as op), args) ->
+      self#select_shift_arith op Ishiftadd Ishiftadd args
+  | ((Csuba | Csubi), [arg; Cconst_int n])
+    when n < 0 && self#is_immediate (-n) ->
+      (Iintop_imm(Iadd, -n), [arg])
+  | ((Csuba | Csubi), [Cconst_int n; arg])
+    when self#is_immediate n ->
+      (Ispecific(Irevsubimm n), [arg])
+  | ((Csuba | Csubi as op), args) ->
+      self#select_shift_arith op Ishiftsub Ishiftsubrev args
+  | (Ccheckbound _, [Cop(Clsr, [arg1; Cconst_int n]); arg2])
+    when n > 0 && n < 32 && not(is_intconst arg2) ->
+      (Ispecific(Ishiftcheckbound n), [arg1; arg2])
+  (* ARM does not support immediate operands for multiplication *)
+  | (Cmuli, args) ->
       (Iintop Imul, args)
-  | Cdivi ->
-      begin match args with
-        [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
-          (Iintop_imm(Idiv, n), [arg1])
-      | _ ->
-          (Iextcall("__divsi3", false), args)
-      end
-  | Cmodi ->
-      begin match args with
-        [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) ->
-          (Iintop_imm(Imod, n), [arg1])
-      | _ ->
-          (Iextcall("__modsi3", false), args)
-      end
-  | Ccheckbound _ ->
-      begin match args with
-        [Cop(Clsr, [arg1; Cconst_int n]); arg2]
-        when n > 0 && n < 32 && not(is_intconst arg2) ->
-          (Ispecific(Ishiftcheckbound n), [arg1; arg2])
-      | _ ->
-        super#select_operation op args
-      end
-  (* Turn floating-point operations into library function calls *)
-  | Caddf -> (Iextcall("__adddf3", false), args)
-  | Csubf -> (Iextcall("__subdf3", false), args)
-  | Cmulf -> (Iextcall("__muldf3", false), args)
-  | Cdivf -> (Iextcall("__divdf3", false), args)
-  | Cfloatofint -> (Iextcall("__floatsidf", false), args)
-  | Cintoffloat -> (Iextcall("__fixdfsi", false), args)
-  | Ccmpf comp ->
-      (Iintop_imm(Icomp(Isigned comp), 0),
-       [Cop(Cextcall(float_comparison_function comp,
-                     typ_int, false, Debuginfo.none),
-            args)])
+  (* Turn integer division/modulus into runtime ABI calls *)
+  | (Cdivi, [arg; Cconst_int n])
+    when n = 1 lsl Misc.log2 n ->
+      (Iintop_imm(Idiv, n), [arg])
+  | (Cdivi, args) ->
+      (Iextcall("__aeabi_idiv", false), args)
+  | (Cmodi, [arg; Cconst_int n])
+    when n = 1 lsl Misc.log2 n ->
+      (Iintop_imm(Imod, n), [arg])
+  | (Cmodi, args) ->
+      (* See above for fix up of return register *)
+      (Iextcall("__aeabi_idivmod", false), args)
+  (* Turn floating-point operations into runtime ABI calls for softfp *)
+  | (op, args) when !fpu = Soft -> self#select_operation_softfp op args
+  (* Select operations for VFPv3 *)
+  | (op, args) -> self#select_operation_vfpv3 op args
+
+method private select_operation_softfp op args =
+  match (op, args) with
+  (* Turn floating-point operations into runtime ABI calls *)
+  | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args)
+  | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args)
+  | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args)
+  | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args)
+  | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args)
+  | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args)
+  | (Ccmpf comp, args) ->
+      let func = (match comp with
+                    Cne    (* there's no __aeabi_dcmpne *)
+                  | Ceq -> "__aeabi_dcmpeq"
+                  | Clt -> "__aeabi_dcmplt"
+                  | Cle -> "__aeabi_dcmple"
+                  | Cgt -> "__aeabi_dcmpgt"
+                  | Cge -> "__aeabi_dcmpge") in
+      let comp = (match comp with
+                    Cne -> Ceq (* eq 0 => false *)
+                  | _   -> Cne (* ne 0 => true *)) in
+      (Iintop_imm(Icomp(Iunsigned comp), 0),
+       [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)])
   (* Add coercions around loads and stores of 32-bit floats *)
-  | Cload Single ->
-      (Iextcall("__extendsfdf2", false), [Cop(Cload Word, args)])
-  | Cstore Single ->
-      begin match args with
-      | [arg1; arg2] ->
-          let arg2' =
-            Cop(Cextcall("__truncdfsf2", typ_int, false, Debuginfo.none),
-                [arg2]) in
-          self#select_operation (Cstore Word) [arg1; arg2']
-      | _ -> assert false
-      end
+  | (Cload Single, args) ->
+      (Iextcall("__aeabi_f2d", false), [Cop(Cload Word, args)])
+  | (Cstore Single, [arg1; arg2]) ->
+      let arg2' =
+        Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none),
+            [arg2]) in
+      self#select_operation (Cstore Word) [arg1; arg2']
   (* Other operations are regular *)
-  | _ -> super#select_operation op args
+  | (op, args) -> super#select_operation op args
+
+method private select_operation_vfpv3 op args =
+  match (op, args) with
+  (* Recognize floating-point negate and multiply *)
+    (Cnegf, [Cop(Cmulf, args)]) ->
+      (Ispecific Inegmulf, args)
+  (* Recognize floating-point multiply and add *)
+  | (Caddf, [arg; Cop(Cmulf, args)])
+  | (Caddf, [Cop(Cmulf, args); arg]) ->
+      (Ispecific Imuladdf, arg :: args)
+  (* Recognize floating-point negate, multiply and subtract *)
+  | (Csubf, [Cop(Cnegf, [arg]); Cop(Cmulf, args)])
+  | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args)]); arg]) ->
+      (Ispecific Inegmulsubf, arg :: args)
+  (* Recognize floating-point negate, multiply and add *)
+  | (Csubf, [arg; Cop(Cmulf, args)]) ->
+      (Ispecific Inegmuladdf, arg :: args)
+  (* Recognize multiply and subtract *)
+  | (Csubf, [Cop(Cmulf, args); arg]) ->
+      (Ispecific Imulsubf, arg :: args)
+  (* Recognize floating-point square root *)
+  | (Cextcall("sqrt", _, false, _), args) ->
+      (Ispecific Isqrtf, args)
+  (* Other operations are regular *)
+  | (op, args) -> super#select_operation op args
 
 method! select_condition = function
-  | Cop(Ccmpf cmp, args) ->
-      (Iinttest_imm(Isigned cmp, 0),
-       Cop(Cextcall(float_comparison_function cmp,
-                    typ_int, false, Debuginfo.none),
-           args))
+  (* Turn floating-point comparisons into runtime ABI calls *)
+    Cop(Ccmpf _ as op, args) when !fpu = Soft ->
+      begin match self#select_operation_softfp op args with
+        (Iintop_imm(Icomp(Iunsigned Ceq), 0), [arg]) -> (Ifalsetest, arg)
+      | (Iintop_imm(Icomp(Iunsigned Cne), 0), [arg]) -> (Itruetest, arg)
+      | _ -> assert false
+      end
   | expr ->
       super#select_condition expr
 
-(* Deal with some register irregularities:
-
-1- In mul rd, rm, rs,  the registers rm and rd must be different.
-   We deal with this by pretending that rm is also a result of the mul
-   operation.
-
-2- For Inegf and Iabsf, force arguments and results in (r0, r1);
-   this simplifies code generation later.
-*)
+(* Deal with some register constraints *)
 
 method! insert_op_debug op dbg rs rd =
-  match op with
-  | Iintop(Imul) ->
-      self#insert_debug (Iop op) dbg rs [| rd.(0); rs.(0) |]; rd
-  | Iabsf | Inegf ->
-      let r = [| phys_reg 0; phys_reg 1 |] in
-      self#insert_moves rs r;
-      self#insert_debug (Iop op) dbg r r;
-      self#insert_moves r rd;
-      rd
-  | _ ->
-      super#insert_op_debug op dbg rs rd
+  try
+    let (rsrc, rdst) = pseudoregs_for_operation op rs rd in
+    self#insert_moves rs rsrc;
+    self#insert_debug (Iop op) dbg rsrc rdst;
+    self#insert_moves rdst rd;
+    rd
+  with Use_default ->
+    super#insert_op_debug op dbg rs rd
 
 end
 

diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml
index 9cdf61f40cc810ac29133ec42656fac4aa4c3ad6..5f513db1bb2c45fa9e2179851f20817c94d4b460 100644 (file)
--- a/asmcomp/asmgen.ml
+++ b/asmcomp/asmgen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -135,4 +135,5 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) =
 
 let report_error ppf = function
   | Assembler_error file ->
-      fprintf ppf "Assembler error, input left in file %s" file
+      fprintf ppf "Assembler error, input left in file %a"
+        Location.print_filename file

diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli
index fe578bd4f548ca03772c0ceb866e595e36c5168c..f71cba8f7cedc6e2e318049f9a14722882f9568d 100644 (file)
--- a/asmcomp/asmgen.mli
+++ b/asmcomp/asmgen.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml
index 1fddb81279af6ce03e6c5b0f37084dfe9d044e6e..e0d2170b5a01e093a54d1ae053d2fb277058f80a 100644 (file)
--- a/asmcomp/asmlibrarian.ml
+++ b/asmcomp/asmlibrarian.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/asmlibrarian.mli b/asmcomp/asmlibrarian.mli
index 66f6a127fd299c26fbba7c4bbbeec33cd4b72dbb..20a0380c9c214bd927b6cb51dce385a98d7343af 100644 (file)
--- a/asmcomp/asmlibrarian.mli
+++ b/asmcomp/asmlibrarian.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
index e8930139b10d15192656775ed88a95dca66e5499..e99e62a3974843a08a8f55f525282c844e87a311 100644 (file)
--- a/asmcomp/asmlink.ml
+++ b/asmcomp/asmlink.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -101,7 +101,7 @@ let runtime_lib () =
   let libname =
     if !Clflags.gprofile
     then "libasmrunp" ^ ext_lib
-    else "libasmrun" ^ ext_lib in
+    else "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in
   try
     if !Clflags.nopervasives then []
     else [ find_in_path !load_path libname ]
@@ -342,7 +342,8 @@ let report_error ppf = function
   | File_not_found name ->
       fprintf ppf "Cannot find file %s" name
   | Not_an_object_file name ->
-      fprintf ppf "The file %s is not a compilation unit description" name
+      fprintf ppf "The file %a is not a compilation unit description"
+        Location.print_filename name
   | Missing_implementations l ->
      let print_references ppf = function
        | [] -> ()
@@ -359,27 +360,35 @@ let report_error ppf = function
        print_modules l
   | Inconsistent_interface(intf, file1, file2) ->
       fprintf ppf
-       "@[<hov>Files %s@ and %s@ make inconsistent assumptions \
+       "@[<hov>Files %a@ and %a@ make inconsistent assumptions \
               over interface %s@]"
-       file1 file2 intf
+       Location.print_filename file1
+       Location.print_filename file2
+       intf
   | Inconsistent_implementation(intf, file1, file2) ->
       fprintf ppf
-       "@[<hov>Files %s@ and %s@ make inconsistent assumptions \
+       "@[<hov>Files %a@ and %a@ make inconsistent assumptions \
               over implementation %s@]"
-       file1 file2 intf
+       Location.print_filename file1
+       Location.print_filename file2
+       intf
   | Assembler_error file ->
-      fprintf ppf "Error while assembling %s" file
+      fprintf ppf "Error while assembling %a" Location.print_filename file
   | Linking_error ->
       fprintf ppf "Error during linking"
   | Multiple_definition(modname, file1, file2) ->
       fprintf ppf
-        "@[<hov>Files %s@ and %s@ both define a module named %s@]"
-        file1 file2 modname
+        "@[<hov>Files %a@ and %a@ both define a module named %s@]"
+        Location.print_filename file1
+        Location.print_filename file2
+        modname
   | Missing_cmx(filename, name) ->
       fprintf ppf
-        "@[<hov>File %s@ was compiled without access@ \
+        "@[<hov>File %a@ was compiled without access@ \
          to the .cmx file@ for module %s,@ \
          which was produced by `ocamlopt -for-pack'.@ \
-         Please recompile %s@ with the correct `-I' option@ \
+         Please recompile %a@ with the correct `-I' option@ \
          so that %s.cmx@ is found.@]"
-        filename name filename name
+        Location.print_filename filename name
+        Location.print_filename  filename
+        name

diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli
index dbebb7bedabc8568cb18b676b597ae24afa7e459..b9465f8090ca7c926f6efd0bba9418832c6252e4 100644 (file)
--- a/asmcomp/asmlink.mli
+++ b/asmcomp/asmlink.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml
index fadfa49f7a3ee7efecad5dc8e6f6e7a42319ec0e..3f44a0a9816bfb69623b6e123e909f055351d1c4 100644 (file)
--- a/asmcomp/asmpackager.ml
+++ b/asmcomp/asmpackager.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -193,13 +193,14 @@ open Format
 
 let report_error ppf = function
     Illegal_renaming(file, id) ->
-      fprintf ppf "Wrong file naming: %s@ contains the code for@ %s"
-        file id
+      fprintf ppf "Wrong file naming: %a@ contains the code for@ %s"
+        Location.print_filename file id
   | Forward_reference(file, ident) ->
-      fprintf ppf "Forward reference to %s in file %s" ident file
+      fprintf ppf "Forward reference to %s in file %a" ident
+        Location.print_filename file
   | Wrong_for_pack(file, path) ->
-      fprintf ppf "File %s@ was not compiled with the `-for-pack %s' option"
-              file path
+      fprintf ppf "File %a@ was not compiled with the `-for-pack %s' option"
+              Location.print_filename file path
   | File_not_found file ->
       fprintf ppf "File %s not found" file
   | Assembler_error file ->

diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli
index 7d0bb588b52859bcf50f954e1b5ffa0f02f99a18..fafccfea3b3e226ff0a6b1417752bbe64c034dc0 100644 (file)
--- a/asmcomp/asmpackager.mli
+++ b/asmcomp/asmpackager.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml
index 5e31c3bbb552eff5fb3f0b182604bec44cbda588..9a01de819e4f6b828b6790d3b4710d84badcf494 100644 (file)
--- a/asmcomp/clambda.ml
+++ b/asmcomp/clambda.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -22,11 +22,10 @@ type function_label = string
 
 type ulambda =
     Uvar of Ident.t
-  | Uconst of structured_constant
+  | Uconst of structured_constant * string option
   | Udirect_apply of function_label * ulambda list * Debuginfo.t
   | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
-  | Uclosure of (function_label * int * Ident.t list * ulambda) list
-              * ulambda list
+  | Uclosure of ufunction list * ulambda list
   | Uoffset of ulambda * int
   | Ulet of Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
@@ -42,6 +41,14 @@ type ulambda =
   | Uassign of Ident.t * ulambda
   | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
 
+and ufunction = {
+  label  : function_label;
+  arity  : int;
+  params : Ident.t list;
+  body   : ulambda;
+  dbg    : Debuginfo.t
+}
+
 and ulambda_switch =
   { us_index_consts: int array;
     us_actions_consts : ulambda array;

diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli
index 724490c527f6dafac97b84ee85cff2b15545d886..808c1c6dae3b6a1e509ffd497104e1d1de152a0c 100644 (file)
--- a/asmcomp/clambda.mli
+++ b/asmcomp/clambda.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -22,11 +22,10 @@ type function_label = string
 
 type ulambda =
     Uvar of Ident.t
-  | Uconst of structured_constant
+  | Uconst of structured_constant * string option
   | Udirect_apply of function_label * ulambda list * Debuginfo.t
   | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
-  | Uclosure of (function_label * int * Ident.t list * ulambda) list
-              * ulambda list
+  | Uclosure of ufunction list * ulambda list
   | Uoffset of ulambda * int
   | Ulet of Ident.t * ulambda * ulambda
   | Uletrec of (Ident.t * ulambda) list * ulambda
@@ -42,6 +41,14 @@ type ulambda =
   | Uassign of Ident.t * ulambda
   | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
 
+and ufunction = {
+  label  : function_label;
+  arity  : int;
+  params : Ident.t list;
+  body   : ulambda;
+  dbg    : Debuginfo.t;
+}
+
 and ulambda_switch =
   { us_index_consts: int array;
     us_actions_consts: ulambda array;

diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 4ff4d72098b54fc5ff9d75f1c2ce7504dc9e1db8..03ed0c12418acfde17ae8a809221a0abc9fda52c 100644 (file)
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -50,7 +50,7 @@ let getglobal id =
 let occurs_var var u =
   let rec occurs = function
       Uvar v -> v = var
-    | Uconst cst -> false
+    | Uconst (cst,_) -> false
     | Udirect_apply(lbl, args, _) -> List.exists occurs args
     | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
     | Uclosure(fundecls, clos) -> List.exists occurs clos
@@ -120,9 +120,12 @@ let lambda_smaller lam threshold =
     if !size > threshold then raise Exit;
     match lam with
       Uvar v -> ()
-    | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
+    | Uconst(
+       (Const_base(Const_int _ | Const_char _ | Const_float _ |
                         Const_int32 _ | Const_int64 _ | Const_nativeint _) |
-             Const_pointer _) -> incr size
+             Const_pointer _), _) -> incr size
+(* Structured Constants are now emitted during closure conversion. *)
+    | Uconst (_, Some _) -> incr size
     | Uconst _ ->
         raise Exit (* avoid duplication of structured constants *)
     | Udirect_apply(fn, args, _) ->
@@ -177,7 +180,7 @@ let lambda_smaller lam threshold =
 
 let rec is_pure_clambda = function
     Uvar v -> true
-  | Uconst cst -> true
+  | Uconst _ -> true
   | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
            Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
            Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
@@ -186,8 +189,8 @@ let rec is_pure_clambda = function
 
 (* Simplify primitive operations on integers *)
 
-let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n)
-let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n)
+let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n)
+let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n)
 let make_const_bool b = make_const_ptr(if b then 1 else 0)
 
 let simplif_prim_pure p (args, approxs) dbg =
@@ -254,16 +257,16 @@ let simplif_prim p (args, approxs as args_approxs) dbg =
    over functions. *)
 
 let approx_ulam = function
-    Uconst(Const_base(Const_int n)) -> Value_integer n
-  | Uconst(Const_base(Const_char c)) -> Value_integer(Char.code c)
-  | Uconst(Const_pointer n) -> Value_constptr n
+    Uconst(Const_base(Const_int n),_) -> Value_integer n
+  | Uconst(Const_base(Const_char c),_) -> Value_integer(Char.code c)
+  | Uconst(Const_pointer n,_) -> Value_constptr n
   | _ -> Value_unknown
 
 let rec substitute sb ulam =
   match ulam with
     Uvar v ->
       begin try Tbl.find v sb with Not_found -> ulam end
-  | Uconst cst -> ulam
+  | Uconst _ -> ulam
   | Udirect_apply(lbl, args, dbg) ->
       Udirect_apply(lbl, List.map (substitute sb) args, dbg)
   | Ugeneric_apply(fn, args, dbg) ->
@@ -313,7 +316,7 @@ let rec substitute sb ulam =
       Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2)
   | Uifthenelse(u1, u2, u3) ->
       begin match substitute sb u1 with
-        Uconst(Const_pointer n) ->
+        Uconst(Const_pointer n, _) ->
           if n <> 0 then substitute sb u2 else substitute sb u3
       | su1 ->
           Uifthenelse(su1, substitute sb u2, substitute sb u3)
@@ -339,14 +342,14 @@ let rec substitute sb ulam =
 let is_simple_argument = function
     Uvar _ -> true
   | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
-                      Const_int32 _ | Const_int64 _ | Const_nativeint _)) ->
+                      Const_int32 _ | Const_int64 _ | Const_nativeint _),_) ->
       true
-  | Uconst(Const_pointer _) -> true
+  | Uconst(Const_pointer _, _) -> true
   | _ -> false
 
 let no_effects = function
     Uclosure _ -> true
-  | Uconst(Const_base(Const_string _)) -> true
+  | Uconst(Const_base(Const_string _),_) -> true
   | u -> is_simple_argument u
 
 let rec bind_params_rec subst params args body =
@@ -485,13 +488,16 @@ let rec close fenv cenv = function
       close_approx_var fenv cenv id
   | Lconst cst ->
       begin match cst with
-        Const_base(Const_int n) -> (Uconst cst, Value_integer n)
-      | Const_base(Const_char c) -> (Uconst cst, Value_integer(Char.code c))
-      | Const_pointer n -> (Uconst cst, Value_constptr n)
-      | _ -> (Uconst cst, Value_unknown)
+        Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n)
+      | Const_base(Const_char c) -> (Uconst (cst,None), Value_integer(Char.code c))
+      | Const_pointer n -> (Uconst (cst, None), Value_constptr n)
+      | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), Value_unknown)
       end
   | Lfunction(kind, params, body) as funct ->
       close_one_function fenv cenv (Ident.create "fun") funct
+
+    (* We convert [f a] to [let a' = a in fun b c -> f a' b c] 
+       when fun_arity > nargs *)
   | Lapply(funct, args, loc) ->
       let nargs = List.length args in
       begin match (close fenv cenv funct, close_list fenv cenv args) with
@@ -504,6 +510,31 @@ let rec close fenv cenv = function
         when nargs = fundesc.fun_arity ->
           let app = direct_apply fundesc funct ufunct uargs in
           (app, strengthen_approx app approx_res)
+
+      | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
+          when nargs < fundesc.fun_arity ->
+       let first_args = List.map (fun arg ->
+         (Ident.create "arg", arg) ) uargs in
+       let final_args = Array.to_list (Array.init (fundesc.fun_arity - nargs) (fun _ ->
+         Ident.create "arg")) in
+       let rec iter args body =
+         match args with
+             [] -> body
+           | (arg1, arg2) :: args ->
+             iter args
+               (Ulet ( arg1, arg2, body))
+       in
+       let internal_args =
+         (List.map (fun (arg1, arg2) -> Lvar arg1) first_args)
+         @ (List.map (fun arg -> Lvar arg ) final_args)
+       in
+       let (new_fun, approx) = close fenv cenv
+         (Lfunction(
+           Curried, final_args, Lapply(funct, internal_args, loc)))
+       in
+       let new_fun = iter first_args new_fun in
+       (new_fun, approx)
+
       | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
         when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
           let (first_args, rem_args) = split_list fundesc.fun_arity uargs in
@@ -563,6 +594,9 @@ let rec close fenv cenv = function
         let (ubody, approx) = close fenv_body cenv body in
         (Uletrec(udefs, ubody), approx)
       end
+  | Lprim(Pdirapply loc,[funct;arg])
+  | Lprim(Prevapply loc,[arg;funct]) ->
+      close fenv cenv (Lapply(funct, [arg], loc))
   | Lprim(Pgetglobal id, []) as lam ->
       check_constant_result lam
                             (getglobal id)
@@ -714,6 +748,9 @@ and close_functions fenv cenv fun_defs =
   let useless_env = ref initially_closed in
   (* Translate each function definition *)
   let clos_fundef (id, params, body, fundesc) env_pos =
+    let dbg = match body with
+      | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev
+      | _ -> Debuginfo.none in
     let env_param = Ident.create "env" in
     let cenv_fv =
       build_closure_env env_param (fv_pos - env_pos) fv in
@@ -725,7 +762,11 @@ and close_functions fenv cenv fun_defs =
     let (ubody, approx) = close fenv_rec cenv_body body in
     if !useless_env && occurs_var env_param ubody then useless_env := false;
     let fun_params = if !useless_env then params else params @ [env_param] in
-    ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody),
+    ({ label  = fundesc.fun_label;
+       arity  = fundesc.fun_arity;
+       params = fun_params;
+       body   = ubody;
+       dbg },
      (id, env_pos, Value_closure(fundesc, approx))) in
   (* Translate all function definitions. *)
   let clos_info_list =
@@ -755,11 +796,12 @@ and close_functions fenv cenv fun_defs =
 
 and close_one_function fenv cenv id funct =
   match close_functions fenv cenv [id, funct] with
-      ((Uclosure([_, _, params, body], _) as clos),
+      ((Uclosure([f], _) as clos),
        [_, _, (Value_closure(fundesc, _) as approx)]) ->
         (* See if the function can be inlined *)
-        if lambda_smaller body (!Clflags.inline_threshold + List.length params)
-        then fundesc.fun_inline <- Some(params, body);
+        if lambda_smaller f.body
+          (!Clflags.inline_threshold + List.length f.params)
+        then fundesc.fun_inline <- Some(f.params, f.body);
         (clos, approx)
     | _ -> fatal_error "Closure.close_one_function"
 

diff --git a/asmcomp/closure.mli b/asmcomp/closure.mli
index f16379068d99da7bbef3fa48f949bc112f48e298..f406603c2cdaca53a4ca0f98b4ee110d24c14803 100644 (file)
--- a/asmcomp/closure.mli
+++ b/asmcomp/closure.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml
index 68625e24c8ff7dded7b1fb09644a54075fc1ad7c..7787a22042f66882566a48fe502b5d3212edc598 100644 (file)
--- a/asmcomp/cmm.ml
+++ b/asmcomp/cmm.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -108,7 +108,8 @@ type fundecl =
   { fun_name: string;
     fun_args: (Ident.t * machtype) list;
     fun_body: expression;
-    fun_fast: bool }
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t; }
 
 type data_item =
     Cdefine_symbol of string

diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli
index 1b09071657c8f4fb1f397598a7e4047a17168214..5787bcb961c42c240b68755f41840a89fe237c59 100644 (file)
--- a/asmcomp/cmm.mli
+++ b/asmcomp/cmm.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -94,7 +94,8 @@ type fundecl =
   { fun_name: string;
     fun_args: (Ident.t * machtype) list;
     fun_body: expression;
-    fun_fast: bool }
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t; }
 
 type data_item =
     Cdefine_symbol of string

diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index ca9d2f0418dffed017c54d312bdb36e09f1d1cb8..0b5d09db7d2a527d7146a0881a36f4c8cd12f2da 100644 (file)
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -159,13 +159,16 @@ let ignore_low_bit_int = function
   | Cop(Cor, [c; Cconst_int 1]) -> c
   | c -> c
 
-let is_nonzero_constant = function
-    Cconst_int n -> n <> 0
-  | Cconst_natint n -> n <> 0n
+(* Division or modulo on tagged integers.  The overflow case min_int / -1
+   cannot occur, but we must guard against division by zero. *)
+
+let is_different_from x = function
+    Cconst_int n -> n <> x
+  | Cconst_natint n -> n <> Nativeint.of_int x
   | _ -> false
 
 let safe_divmod op c1 c2 dbg =
-  if !Clflags.fast || is_nonzero_constant c2 then
+  if !Clflags.fast || is_different_from 0 c2 then
     Cop(op, [c1; c2])
   else
     bind "divisor" c2 (fun c2 ->
@@ -174,6 +177,35 @@ let safe_divmod op c1 c2 dbg =
                   Cop(Craise dbg,
                       [Cconst_symbol "caml_bucket_Division_by_zero"])))
 
+(* Division or modulo on boxed integers.  The overflow case min_int / -1
+   can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *)
+
+let safe_divmod_bi mkop mkm1 c1 c2 bi dbg =
+  bind "dividend" c1 (fun c1 ->
+  bind "divisor" c2 (fun c2 ->
+    let c3 =
+      if Arch.division_crashes_on_overflow
+      && (size_int = 4 || bi <> Pint32)
+      && not (is_different_from (-1) c2)
+      then
+        Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), mkop c1 c2, mkm1 c1)
+      else
+        mkop c1 c2 in
+    if !Clflags.fast || is_different_from 0 c2 then
+      c3
+    else
+      Cifthenelse(c2, c3,
+                  Cop(Craise dbg,
+                      [Cconst_symbol "caml_bucket_Division_by_zero"]))))
+
+let safe_div_bi =
+  safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2]))
+                 (fun c1 -> Cop(Csubi, [Cconst_int 0; c1]))
+
+let safe_mod_bi =
+  safe_divmod_bi (fun c1 c2 -> Cop(Cmodi, [c1;c2]))
+                 (fun c1 -> Cconst_int 0)
+
 (* Bool *)
 
 let test_bool = function
@@ -369,18 +401,26 @@ let make_float_alloc tag args =
   make_alloc_generic float_array_set tag
                      (List.length args * size_float / size_addr) args
 
+(* Bounds checking *)
+
+let make_checkbound dbg = function
+  | [Cop(Clsr, [a1; Cconst_int n]); Cconst_int m] when (m lsl n) > n ->
+      Cop(Ccheckbound dbg, [a1; Cconst_int(m lsl n + 1 lsl n - 1)])
+  | args ->
+      Cop(Ccheckbound dbg, args)
+
 (* To compile "let rec" over values *)
 
 let fundecls_size fundecls =
   let sz = ref (-1) in
   List.iter
-    (fun (label, arity, params, body) ->
-      sz := !sz + 1 + (if arity = 1 then 2 else 3))
+    (fun f -> sz := !sz + 1 + (if f.arity = 1 then 2 else 3))
     fundecls;
   !sz
 
 type rhs_kind =
   | RHS_block of int
+  | RHS_floatblock of int
   | RHS_nonrec
 ;;
 let rec expr_size = function
@@ -394,6 +434,8 @@ let rec expr_size = function
       RHS_block (List.length args)
   | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) ->
       RHS_block (List.length args)
+  | Uprim(Pmakearray(Pfloatarray), args, _) ->
+      RHS_floatblock (List.length args)
   | Usequence(exp, exp') ->
       expr_size exp'
   | _ -> RHS_nonrec
@@ -420,6 +462,7 @@ let transl_comparison = function
 
 (* Translate structured constants *)
 
+(* Fabrice: moved to compilenv.ml ----
 let const_label = ref 0
 
 let new_const_label () =
@@ -431,6 +474,7 @@ let new_const_symbol () =
   Compilenv.make_symbol (Some (string_of_int !const_label))
 
 let structured_constants = ref ([] : (string * structured_constant) list)
+*)
 
 let transl_constant = function
     Const_base(Const_int n) ->
@@ -443,14 +487,12 @@ let transl_constant = function
       else Cconst_natpointer
               (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
   | cst ->
-      let lbl = new_const_symbol() in
-      structured_constants := (lbl, cst) :: !structured_constants;
-      Cconst_symbol lbl
+      Cconst_symbol (Compilenv.new_structured_constant cst false)
 
 (* Translate constant closures *)
 
 let constant_closures =
-  ref ([] : (string * (string * int * Ident.t list * ulambda) list) list)
+  ref ([] : (string * ufunction list) list)
 
 (* Boxed integers *)
 
@@ -534,7 +576,7 @@ let bigarray_elt_size = function
 
 let bigarray_indexing unsafe elt_kind layout b args dbg =
   let check_bound a1 a2 k =
-    if unsafe then k else Csequence(Cop(Ccheckbound dbg, [a1;a2]), k) in
+    if unsafe then k else Csequence(make_checkbound dbg [a1;a2], k) in
   let rec ba_indexing dim_ofs delta_ofs = function
     [] -> assert false
   | [arg] ->
@@ -726,7 +768,7 @@ type unboxed_number_kind =
   | Boxed_integer of boxed_integer
 
 let is_unboxed_number = function
-    Uconst(Const_base(Const_float f)) ->
+    Uconst(Const_base(Const_float f), _) ->
       Boxed_float
   | Uprim(p, _, _) ->
       begin match simplif_primitive p with
@@ -797,20 +839,19 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp =
 
 (* Translate an expression *)
 
-let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t)
+let functions = (Queue.create() : ufunction Queue.t)
 
 let rec transl = function
     Uvar id ->
       Cvar id
-  | Uconst sc ->
+  | Uconst (sc, Some const_label) ->
+      Cconst_symbol const_label
+  | Uconst (sc, None) ->
       transl_constant sc
   | Uclosure(fundecls, []) ->
-      let lbl = new_const_symbol() in
+      let lbl = Compilenv.new_const_symbol() in
       constant_closures := (lbl, fundecls) :: !constant_closures;
-      List.iter
-        (fun (label, arity, params, body) ->
-          Queue.add (label, params, body) functions)
-        fundecls;
+      List.iter (fun f -> Queue.add f functions) fundecls;
       Cconst_symbol lbl
   | Uclosure(fundecls, clos_vars) ->
       let block_size =
@@ -818,22 +859,22 @@ let rec transl = function
       let rec transl_fundecls pos = function
           [] ->
             List.map transl clos_vars
-        | (label, arity, params, body) :: rem ->
-            Queue.add (label, params, body) functions;
+        | f :: rem ->
+            Queue.add f functions;
             let header =
               if pos = 0
               then alloc_closure_header block_size
               else alloc_infix_header pos in
-            if arity = 1 then
+            if f.arity = 1 then
               header ::
-              Cconst_symbol label ::
+              Cconst_symbol f.label ::
               int_const 1 ::
               transl_fundecls (pos + 3) rem
             else
               header ::
-              Cconst_symbol(curry_function arity) ::
-              int_const arity ::
-              Cconst_symbol label ::
+              Cconst_symbol(curry_function f.arity) ::
+              int_const f.arity ::
+              Cconst_symbol f.label ::
               transl_fundecls (pos + 4) rem in
       Cop(Calloc, transl_fundecls 0 fundecls)
   | Uoffset(arg, offset) ->
@@ -1070,7 +1111,7 @@ and transl_prim_1 p arg dbg =
       if no_overflow_lsl n then
         add_const (transl arg) (n lsl 1)
       else
-        transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) Debuginfo.none
+        transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) Debuginfo.none
   | Poffsetref n ->
       return_unit
         (bind "ref" (transl arg) (fun arg ->
@@ -1207,7 +1248,7 @@ and transl_prim_2 p arg1 arg2 dbg =
         (bind "str" (transl arg1) (fun str ->
           bind "index" (untag_int (transl arg2)) (fun idx ->
             Csequence(
-              Cop(Ccheckbound dbg, [string_length str; idx]),
+              make_checkbound dbg [string_length str; idx],
               Cop(Cload Byte_unsigned, [add_int str idx])))))
 
   (* Array operations *)
@@ -1226,26 +1267,31 @@ and transl_prim_2 p arg1 arg2 dbg =
       end
   | Parrayrefs kind ->
       begin match kind with
-        Pgenarray ->
+      | Pgenarray ->
           bind "index" (transl arg2) (fun idx ->
-            bind "arr" (transl arg1) (fun arr ->
-              bind "header" (header arr) (fun hdr ->
-                Cifthenelse(is_addr_array_hdr hdr,
-                  Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]),
-                            addr_array_ref arr idx),
-                  Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]),
-                            float_array_ref arr idx)))))
+          bind "arr" (transl arg1) (fun arr ->
+          bind "header" (header arr) (fun hdr ->
+            if wordsize_shift = numfloat_shift then
+              Csequence(make_checkbound dbg [addr_array_length hdr; idx],
+                        Cifthenelse(is_addr_array_hdr hdr, 
+                                    addr_array_ref arr idx,
+                                    float_array_ref arr idx))
+            else
+              Cifthenelse(is_addr_array_hdr hdr,
+                Csequence(make_checkbound dbg [addr_array_length hdr; idx],
+                          addr_array_ref arr idx),
+                Csequence(make_checkbound dbg [float_array_length hdr; idx],
+                          float_array_ref arr idx)))))
       | Paddrarray | Pintarray ->
           bind "index" (transl arg2) (fun idx ->
             bind "arr" (transl arg1) (fun arr ->
-              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
+              Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
                         addr_array_ref arr idx)))
       | Pfloatarray ->
           box_float(
             bind "index" (transl arg2) (fun idx ->
               bind "arr" (transl arg1) (fun arr ->
-                Csequence(Cop(Ccheckbound dbg,
-                              [float_array_length(header arr); idx]),
+                Csequence(make_checkbound dbg [float_array_length(header arr); idx],
                           unboxed_float_array_ref arr idx))))
       end
 
@@ -1270,13 +1316,13 @@ and transl_prim_2 p arg1 arg2 dbg =
       box_int bi (Cop(Cmuli,
                       [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
   | Pdivbint bi ->
-      box_int bi (safe_divmod Cdivi
+      box_int bi (safe_div_bi
                       (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)
-                      dbg)
+                      bi dbg)
   | Pmodbint bi ->
-      box_int bi (safe_divmod Cmodi
+      box_int bi (safe_mod_bi
                       (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)
-                      dbg)
+                      bi dbg)
   | Pandbint bi ->
       box_int bi (Cop(Cand,
                      [transl_unbox_int bi arg1; transl_unbox_int bi arg2]))
@@ -1314,7 +1360,7 @@ and transl_prim_3 p arg1 arg2 arg3 dbg =
         (bind "str" (transl arg1) (fun str ->
           bind "index" (untag_int (transl arg2)) (fun idx ->
             Csequence(
-              Cop(Ccheckbound dbg, [string_length str; idx]),
+              make_checkbound dbg [string_length str; idx],
               Cop(Cstore Byte_unsigned,
                   [add_int str idx; untag_int(transl arg3)])))))
 
@@ -1337,48 +1383,58 @@ and transl_prim_3 p arg1 arg2 arg3 dbg =
       end)
   | Parraysets kind ->
       return_unit(begin match kind with
-        Pgenarray ->
+      | Pgenarray ->
           bind "newval" (transl arg3) (fun newval ->
-            bind "index" (transl arg2) (fun idx ->
-              bind "arr" (transl arg1) (fun arr ->
-                bind "header" (header arr) (fun hdr ->
-                  Cifthenelse(is_addr_array_hdr hdr,
-                    Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]),
-                              addr_array_set arr idx newval),
-                    Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]),
-                              float_array_set arr idx
-                                              (unbox_float newval)))))))
+          bind "index" (transl arg2) (fun idx ->
+          bind "arr" (transl arg1) (fun arr ->
+          bind "header" (header arr) (fun hdr ->
+            if wordsize_shift = numfloat_shift then
+              Csequence(make_checkbound dbg [addr_array_length hdr; idx],
+                        Cifthenelse(is_addr_array_hdr hdr, 
+                                    addr_array_set arr idx newval,
+                                    float_array_set arr idx
+                                                    (unbox_float newval)))
+            else
+              Cifthenelse(is_addr_array_hdr hdr,
+                Csequence(make_checkbound dbg [addr_array_length hdr; idx],
+                          addr_array_set arr idx newval),
+                Csequence(make_checkbound dbg [float_array_length hdr; idx],
+                          float_array_set arr idx
+                                          (unbox_float newval)))))))
       | Paddrarray ->
+          bind "newval" (transl arg3) (fun newval ->
           bind "index" (transl arg2) (fun idx ->
-            bind "arr" (transl arg1) (fun arr ->
-              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
-                        addr_array_set arr idx (transl arg3))))
+          bind "arr" (transl arg1) (fun arr ->
+            Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
+                      addr_array_set arr idx newval))))
       | Pintarray ->
+          bind "newval" (transl arg3) (fun newval ->
           bind "index" (transl arg2) (fun idx ->
-            bind "arr" (transl arg1) (fun arr ->
-              Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]),
-                        int_array_set arr idx (transl arg3))))
+          bind "arr" (transl arg1) (fun arr ->
+            Csequence(make_checkbound dbg [addr_array_length(header arr); idx],
+                      int_array_set arr idx newval))))
       | Pfloatarray ->
+          bind "newval" (transl_unbox_float arg3) (fun newval ->
           bind "index" (transl arg2) (fun idx ->
-            bind "arr" (transl arg1) (fun arr ->
-              Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr);idx]),
-                        float_array_set arr idx (transl_unbox_float arg3))))
+          bind "arr" (transl arg1) (fun arr ->
+            Csequence(make_checkbound dbg [float_array_length(header arr);idx],
+                      float_array_set arr idx newval))))
       end)
   | _ ->
     fatal_error "Cmmgen.transl_prim_3"
 
 and transl_unbox_float = function
-    Uconst(Const_base(Const_float f)) -> Cconst_float f
+    Uconst(Const_base(Const_float f), _) -> Cconst_float f
   | exp -> unbox_float(transl exp)
 
 and transl_unbox_int bi = function
-    Uconst(Const_base(Const_int32 n)) ->
+    Uconst(Const_base(Const_int32 n), _) ->
       Cconst_natint (Nativeint.of_int32 n)
-  | Uconst(Const_base(Const_nativeint n)) ->
+  | Uconst(Const_base(Const_nativeint n), _) ->
       Cconst_natint n
-  | Uconst(Const_base(Const_int64 n)) ->
+  | Uconst(Const_base(Const_int64 n), _) ->
       assert (size_int = 8); Cconst_natint (Int64.to_nativeint n)
-  | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))], _) when bi = bi' ->
+  | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i),_)], _) when bi = bi' ->
       Cconst_int i
   | exp -> unbox_int bi (transl exp)
 
@@ -1411,8 +1467,8 @@ and make_catch2 mk_body handler = match handler with
 
 and exit_if_true cond nfail otherwise =
   match cond with
-  | Uconst (Const_pointer 0) -> otherwise
-  | Uconst (Const_pointer 1) -> Cexit (nfail,[])
+  | Uconst (Const_pointer 0, _) -> otherwise
+  | Uconst (Const_pointer 1, _) -> Cexit (nfail,[])
   | Uprim(Psequor, [arg1; arg2], _) ->
       exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise)
   | Uprim(Psequand, _, _) ->
@@ -1441,8 +1497,8 @@ and exit_if_true cond nfail otherwise =
 
 and exit_if_false cond otherwise nfail =
   match cond with
-  | Uconst (Const_pointer 0) -> Cexit (nfail,[])
-  | Uconst (Const_pointer 1) -> otherwise
+  | Uconst (Const_pointer 0, _) -> Cexit (nfail,[])
+  | Uconst (Const_pointer 1, _) -> otherwise
   | Uprim(Psequand, [arg1; arg2], _) ->
       exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail
   | Uprim(Psequor, _, _) ->
@@ -1502,36 +1558,41 @@ and transl_switch arg index cases = match Array.length cases with
 
 and transl_letrec bindings cont =
   let bsz = List.map (fun (id, exp) -> (id, exp, expr_size exp)) bindings in
+  let op_alloc prim sz =
+    Cop(Cextcall(prim, typ_addr, true, Debuginfo.none), [int_const sz]) in
   let rec init_blocks = function
     | [] -> fill_nonrec bsz
     | (id, exp, RHS_block sz) :: rem ->
-        Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none),
-                     [int_const sz]),
-             init_blocks rem)
+        Clet(id, op_alloc "caml_alloc_dummy" sz, init_blocks rem)
+    | (id, exp, RHS_floatblock sz) :: rem ->
+        Clet(id, op_alloc "caml_alloc_dummy_float" sz, init_blocks rem)
     | (id, exp, RHS_nonrec) :: rem ->
         Clet (id, Cconst_int 0, init_blocks rem)
   and fill_nonrec = function
     | [] -> fill_blocks bsz
-    | (id, exp, RHS_block sz) :: rem -> fill_nonrec rem
+    | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+        fill_nonrec rem
     | (id, exp, RHS_nonrec) :: rem ->
         Clet (id, transl exp, fill_nonrec rem)
   and fill_blocks = function
     | [] -> cont
-    | (id, exp, RHS_block _) :: rem ->
-        Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
-                      [Cvar id; transl exp]),
-                  fill_blocks rem)
+    | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem ->
+        let op =
+          Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none),
+              [Cvar id; transl exp]) in
+        Csequence(op, fill_blocks rem)
     | (id, exp, RHS_nonrec) :: rem ->
         fill_blocks rem
   in init_blocks bsz
 
 (* Translate a function definition *)
 
-let transl_function lbl params body =
-  Cfunction {fun_name = lbl;
-             fun_args = List.map (fun id -> (id, typ_addr)) params;
-             fun_body = transl body;
-             fun_fast = !Clflags.optimize_for_speed}
+let transl_function f =
+  Cfunction {fun_name = f.label;
+             fun_args = List.map (fun id -> (id, typ_addr)) f.params;
+             fun_body = transl f.body;
+             fun_fast = !Clflags.optimize_for_speed;
+             fun_dbg  = f.dbg; }
 
 (* Translate all function definitions *)
 
@@ -1543,12 +1604,13 @@ module StringSet =
 
 let rec transl_all_functions already_translated cont =
   try
-    let (lbl, params, body) = Queue.take functions in
-    if StringSet.mem lbl already_translated then
+    let f = Queue.take functions in
+    if StringSet.mem f.label already_translated then
       transl_all_functions already_translated cont
     else begin
-      transl_all_functions (StringSet.add lbl already_translated)
-                           (transl_function lbl params body :: cont)
+      transl_all_functions
+        (StringSet.add f.label already_translated)
+        (transl_function f :: cont)
     end
   with Queue.Empty ->
     cont
@@ -1601,11 +1663,11 @@ and emit_constant_field field cont =
   | Const_base(Const_char c) ->
       (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont)
   | Const_base(Const_float s) ->
-      let lbl = new_const_label() in
+      let lbl = Compilenv.new_const_label() in
       (Clabel_address lbl,
        Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont)
   | Const_base(Const_string s) ->
-      let lbl = new_const_label() in
+      let lbl = Compilenv.new_const_label() in
       (Clabel_address lbl,
        Cint(string_header (String.length s)) :: Cdefine_label lbl ::
        emit_string_constant s cont)
@@ -1613,24 +1675,24 @@ and emit_constant_field field cont =
       begin try
         (Clabel_address (Hashtbl.find immstrings s), cont)
       with Not_found ->
-        let lbl = new_const_label() in
+        let lbl = Compilenv.new_const_label() in
         Hashtbl.add immstrings s lbl;
         (Clabel_address lbl,
          Cint(string_header (String.length s)) :: Cdefine_label lbl ::
          emit_string_constant s cont)
       end
   | Const_base(Const_int32 n) ->
-      let lbl = new_const_label() in
+      let lbl = Compilenv.new_const_label() in
       (Clabel_address lbl,
        Cint(boxedint32_header) :: Cdefine_label lbl ::
        emit_boxed_int32_constant n cont)
   | Const_base(Const_int64 n) ->
-      let lbl = new_const_label() in
+      let lbl = Compilenv.new_const_label() in
       (Clabel_address lbl,
        Cint(boxedint64_header) :: Cdefine_label lbl ::
        emit_boxed_int64_constant n cont)
   | Const_base(Const_nativeint n) ->
-      let lbl = new_const_label() in
+      let lbl = Compilenv.new_const_label() in
       (Clabel_address lbl,
        Cint(boxedintnat_header) :: Cdefine_label lbl ::
        emit_boxed_nativeint_constant n cont)
@@ -1638,13 +1700,13 @@ and emit_constant_field field cont =
       (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n),
        cont)
   | Const_block(tag, fields) ->
-      let lbl = new_const_label() in
+      let lbl = Compilenv.new_const_label() in
       let (emit_fields, cont1) = emit_constant_fields fields cont in
       (Clabel_address lbl,
        Cint(block_header tag (List.length fields)) :: Cdefine_label lbl ::
        emit_fields @ cont1)
   | Const_float_array(fields) ->
-      let lbl = new_const_label() in
+      let lbl = Compilenv.new_const_label() in
       (Clabel_address lbl,
        Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl ::
        Misc.map_end (fun f -> Cdouble f) fields cont)
@@ -1680,31 +1742,31 @@ and emit_boxed_int64_constant n cont =
 let emit_constant_closure symb fundecls cont =
   match fundecls with
     [] -> assert false
-  | (label, arity, params, body) :: remainder ->
+  | f1 :: remainder ->
       let rec emit_others pos = function
         [] -> cont
-      | (label, arity, params, body) :: rem ->
-          if arity = 1 then
+      | f2 :: rem ->
+          if f2.arity = 1 then
             Cint(infix_header pos) ::
-            Csymbol_address label ::
+            Csymbol_address f2.label ::
             Cint 3n ::
             emit_others (pos + 3) rem
           else
             Cint(infix_header pos) ::
-            Csymbol_address(curry_function arity) ::
-            Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
-            Csymbol_address label ::
+            Csymbol_address(curry_function f2.arity) ::
+            Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) ::
+            Csymbol_address f2.label ::
             emit_others (pos + 4) rem in
       Cint(closure_header (fundecls_size fundecls)) ::
       Cdefine_symbol symb ::
-      if arity = 1 then
-        Csymbol_address label ::
+      if f1.arity = 1 then
+        Csymbol_address f1.label ::
         Cint 3n ::
         emit_others 3 remainder
       else
-        Csymbol_address(curry_function arity) ::
-        Cint(Nativeint.of_int (arity lsl 1 + 1)) ::
-        Csymbol_address label ::
+        Csymbol_address(curry_function f1.arity) ::
+        Cint(Nativeint.of_int (f1.arity lsl 1 + 1)) ::
+        Csymbol_address f1.label ::
         emit_others 4 remainder
 
 (* Emit all structured constants *)
@@ -1712,9 +1774,14 @@ let emit_constant_closure symb fundecls cont =
 let emit_all_constants cont =
   let c = ref cont in
   List.iter
-    (fun (lbl, cst) -> c := Cdata(emit_constant lbl cst []) :: !c)
-    !structured_constants;
-  structured_constants := [];
+    (fun (lbl, global, cst) -> 
+       let cst = emit_constant lbl cst [] in
+       let cst = if global then 
+        Cglobal_symbol lbl :: cst
+       else cst in
+        c:= Cdata(cst):: !c)
+    (Compilenv.structured_constants());
+(*  structured_constants := []; done in Compilenv.reset() *)
   Hashtbl.clear immstrings;   (* PR#3979 *)
   List.iter
     (fun (symb, fundecls) ->
@@ -1730,7 +1797,8 @@ let compunit size ulam =
   let init_code = transl ulam in
   let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry");
                        fun_args = [];
-                       fun_body = init_code; fun_fast = false}] in
+                       fun_body = init_code; fun_fast = false;
+                       fun_dbg  = Debuginfo.none }] in
   let c2 = transl_all_functions StringSet.empty c1 in
   let c3 = emit_all_constants c2 in
   Cdata [Cint(block_header 0 size);
@@ -1859,7 +1927,8 @@ let send_function arity =
    {fun_name = "caml_send" ^ string_of_int arity;
     fun_args = fun_args;
     fun_body = body;
-    fun_fast = true}
+    fun_fast = true;
+    fun_dbg  = Debuginfo.none }
 
 let apply_function arity =
   let (args, clos, body) = apply_function_body arity in
@@ -1868,7 +1937,8 @@ let apply_function arity =
    {fun_name = "caml_apply" ^ string_of_int arity;
     fun_args = List.map (fun id -> (id, typ_addr)) all_args;
     fun_body = body;
-    fun_fast = true}
+    fun_fast = true;
+    fun_dbg  = Debuginfo.none }
 
 (* Generate tuplifying functions:
       (defun caml_tuplifyN (arg clos)
@@ -1887,22 +1957,30 @@ let tuplify_function arity =
     fun_body =
       Cop(Capply(typ_addr, Debuginfo.none),
           get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]);
-    fun_fast = true}
+    fun_fast = true;
+    fun_dbg  = Debuginfo.none }
 
 (* Generate currying functions:
       (defun caml_curryN (arg clos)
-         (alloc HDR caml_curryN_1 arg clos))
+         (alloc HDR caml_curryN_1 <arity (N-1)> caml_curry_N_1_app arg clos))
       (defun caml_curryN_1 (arg clos)
-         (alloc HDR caml_curryN_2 arg clos))
+         (alloc HDR caml_curryN_2 <arity (N-2)> caml_curry_N_2_app arg clos))
       ...
       (defun caml_curryN_N-1 (arg clos)
-         (let (closN-2 clos.cdr
-               closN-3 closN-2.cdr
+         (let (closN-2 clos.vars[1]
+               closN-3 closN-2.vars[1]
                ...
-               clos1 clos2.cdr
-               clos clos1.cdr)
+               clos1 clos2.vars[1]
+               clos clos1.vars[1])
            (app clos.direct
-                clos1.car clos2.car ... closN-2.car clos.car arg clos))) *)
+                clos1.vars[0] ... closN-2.vars[0] clos.vars[0] arg clos)))
+    Special "shortcut" functions are also generated to handle the
+    case where a partially applied function is applied to all remaining
+    arguments in one go.  For instance:
+      (defun caml_curry_N_1_app (arg2 ... argN clos)
+        (let clos' clos.vars[1]
+           (app clos'.direct clos.vars[0] arg2 ... argN clos')))
+*)
 
 let final_curry_function arity =
   let last_arg = Ident.create "arg" in
@@ -1912,18 +1990,27 @@ let final_curry_function arity =
       Cop(Capply(typ_addr, Debuginfo.none),
           get_field (Cvar clos) 2 ::
           args @ [Cvar last_arg; Cvar clos])
-    else begin
+    else
+      if n = arity - 1 then
+       begin
       let newclos = Ident.create "clos" in
       Clet(newclos,
            get_field (Cvar clos) 3,
            curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1))
+       end else
+       begin
+         let newclos = Ident.create "clos" in
+         Clet(newclos,
+               get_field (Cvar clos) 4,
+               curry_fun (get_field (Cvar clos) 3 :: args) newclos (n-1))
     end in
   Cfunction
    {fun_name = "caml_curry" ^ string_of_int arity ^
                "_" ^ string_of_int (arity-1);
     fun_args = [last_arg, typ_addr; last_clos, typ_addr];
     fun_body = curry_fun [] last_clos (arity-1);
-    fun_fast = true}
+    fun_fast = true;
+    fun_dbg  = Debuginfo.none }
 
 let rec intermediate_curry_functions arity num =
   if num = arity - 1 then
@@ -1935,12 +2022,52 @@ let rec intermediate_curry_functions arity num =
     Cfunction
      {fun_name = name2;
       fun_args = [arg, typ_addr; clos, typ_addr];
-      fun_body = Cop(Calloc,
+      fun_body =
+        if arity - num > 2 then
+          Cop(Calloc,
+               [alloc_closure_header 5;
+                Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
+                int_const (arity - num - 1);
+                Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app");
+               Cvar arg; Cvar clos])
+        else
+          Cop(Calloc,
                      [alloc_closure_header 4;
                       Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1));
                       int_const 1; Cvar arg; Cvar clos]);
-      fun_fast = true}
-    :: intermediate_curry_functions arity (num+1)
+      fun_fast = true;
+      fun_dbg  = Debuginfo.none }
+    ::
+      (if arity - num > 2 then
+         let rec iter i =
+           if i <= arity then
+             let arg = Ident.create (Printf.sprintf "arg%d" i) in
+             (arg, typ_addr) :: iter (i+1)
+           else []
+         in
+         let direct_args = iter (num+2) in
+         let rec iter i args clos =
+           if i = 0 then
+             Cop(Capply(typ_addr, Debuginfo.none),
+                 (get_field (Cvar clos) 2) :: args @ [Cvar clos])
+           else
+             let newclos = Ident.create "clos" in
+             Clet(newclos,
+                  get_field (Cvar clos) 4,
+                  iter (i-1) (get_field (Cvar clos) 3 :: args) newclos)
+         in
+         let cf =
+           Cfunction
+             {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app";
+              fun_args = direct_args @ [clos, typ_addr];
+              fun_body = iter (num+1)
+                 (List.map (fun (arg,_) -> Cvar arg) direct_args) clos;
+              fun_fast = true;
+               fun_dbg = Debuginfo.none }
+         in
+         cf :: intermediate_curry_functions arity (num+1)
+       else
+         intermediate_curry_functions arity (num+1))
   end
 
 let curry_function arity =
@@ -1992,7 +2119,8 @@ let entry_point namelist =
   Cfunction {fun_name = "caml_program";
              fun_args = [];
              fun_body = body;
-             fun_fast = false}
+             fun_fast = false;
+             fun_dbg  = Debuginfo.none }
 
 (* Generate the table of globals *)
 

diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli
index ba7e5ad00f0dda2f696ec30cb85123f03de1e904..a192b985e1401a73f7bfbe7671b2ca4190a56c18 100644 (file)
--- a/asmcomp/cmmgen.mli
+++ b/asmcomp/cmmgen.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli
index a43a21dfc11eb8628de6aa5706d203fee140afd6..69cd38234f71b2fd3d33ccd045afac5535365121 100644 (file)
--- a/asmcomp/cmx_format.mli
+++ b/asmcomp/cmx_format.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -16,12 +16,12 @@
 
 (* Each .o file has a matching .cmx file that provides the following infos
    on the compilation unit:
-     - list of other units imported, with CRCs of their .cmx files
+     - list of other units imported, with MD5s of their .cmx files
      - approximation of the structure implemented
        (includes descriptions of known functions: arity and direct entry
         points)
      - list of currying functions and application functions needed
-   The .cmx file contains these infos (as an externed record) plus a CRC
+   The .cmx file contains these infos (as an externed record) plus a MD5
    of these infos *)
 
 type unit_infos =
@@ -40,7 +40,7 @@ type unit_infos =
    infos on the library: *)
 
 type library_infos =
-  { lib_units: (unit_infos * Digest.t) list;  (* List of unit infos w/ CRCs *)
+  { lib_units: (unit_infos * Digest.t) list;  (* List of unit infos w/ MD5s *)
     lib_ccobjs: string list;            (* C object files needed *)
     lib_ccopts: string list }           (* Extra opts to C compiler *)
 

diff --git a/asmcomp/codegen.ml b/asmcomp/codegen.ml
index 280f139408188412101c7f9ed233823effb9f9b0..4b71503f9dd90d099c85dadeb99cca045a67f15a 100644 (file)
--- a/asmcomp/codegen.ml
+++ b/asmcomp/codegen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/codegen.mli b/asmcomp/codegen.mli
index b6d8caa611d870ee6a61721fa02e146fd9a8bbce..43f98e50b2fa663edacb70bf150a4058187f6574 100644 (file)
--- a/asmcomp/codegen.mli
+++ b/asmcomp/codegen.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml
index 37c03a05b29a32228d766894ffc36e10b67b59b8..06c1eb82465777bbb5f942d06586a97cc0a4ad1b 100644 (file)
--- a/asmcomp/coloring.ml
+++ b/asmcomp/coloring.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/coloring.mli b/asmcomp/coloring.mli
index cbfb2d6cd1774cad5f78aa2ffc611b3b7a142a24..72576fa10a44ca7d8645a8f436dbba7c6fe6c55d 100644 (file)
--- a/asmcomp/coloring.mli
+++ b/asmcomp/coloring.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml
index 13dbcaffe20c4aff5b715e0ae81de288230a1fff..9767d2638a0bc98a124a80d2a6d0743de4646f6a 100644 (file)
--- a/asmcomp/comballoc.ml
+++ b/asmcomp/comballoc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/comballoc.mli b/asmcomp/comballoc.mli
index 329e927644fc479b9c66f229f00820e272a2afb4..20be980544b3ff31bf3bdd9468107c65d9565c12 100644 (file)
--- a/asmcomp/comballoc.mli
+++ b/asmcomp/comballoc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml
index cf5001dccc5d671428ab82c9ed0ead4fe6e1f390..4c6e72d0b5a4dfda29f6cdf912159c3a3dff9d45 100644 (file)
--- a/asmcomp/compilenv.ml
+++ b/asmcomp/compilenv.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -29,6 +29,8 @@ exception Error of error
 let global_infos_table =
   (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
 
+let structured_constants = ref ([] : (string * bool * Lambda.structured_constant) list)
+
 let current_unit =
   { ui_name = "";
     ui_symbol = "";
@@ -55,6 +57,7 @@ let symbolname_for_pack pack name =
       Buffer.add_string b name;
       Buffer.contents b
 
+
 let reset ?packname name =
   Hashtbl.clear global_infos_table;
   let symbol = symbolname_for_pack packname name in
@@ -66,7 +69,8 @@ let reset ?packname name =
   current_unit.ui_curry_fun <- [];
   current_unit.ui_apply_fun <- [];
   current_unit.ui_send_fun <- [];
-  current_unit.ui_force_link <- false
+  current_unit.ui_force_link <- false;
+  structured_constants := []
 
 let current_unit_infos () =
   current_unit
@@ -83,8 +87,7 @@ let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
 let read_unit_info filename =
   let ic = open_in_bin filename in
   try
-    let buffer = String.create (String.length cmx_magic_number) in
-    really_input ic buffer 0 (String.length cmx_magic_number);
+    let buffer = input_bytes ic (String.length cmx_magic_number) in
     if buffer <> cmx_magic_number then begin
       close_in ic;
       raise(Error(Not_a_unit_info filename))
@@ -99,8 +102,7 @@ let read_unit_info filename =
 
 let read_library_info filename =
   let ic = open_in_bin filename in
-  let buffer = String.create (String.length cmxa_magic_number) in
-  really_input ic buffer 0 (String.length cmxa_magic_number);
+  let buffer = input_bytes ic (String.length cmxa_magic_number) in
   if buffer <> cmxa_magic_number then
     raise(Error(Not_a_unit_info filename));
   let infos = (input_value ic : library_infos) in
@@ -200,14 +202,36 @@ let save_unit_info filename =
   current_unit.ui_imports_cmi <- Env.imported_units();
   write_unit_info current_unit filename
 
+
+
+let const_label = ref 0
+
+let new_const_label () =
+  incr const_label;
+  !const_label
+
+let new_const_symbol () =
+  incr const_label;
+  make_symbol (Some (string_of_int !const_label))
+
+let new_structured_constant cst global =
+  let lbl = new_const_symbol() in
+  structured_constants := (lbl, global, cst) :: !structured_constants;
+  lbl
+
+let structured_constants () = !structured_constants
+
 (* Error report *)
 
 open Format
 
 let report_error ppf = function
   | Not_a_unit_info filename ->
-      fprintf ppf "%s@ is not a compilation unit description." filename
+      fprintf ppf "%a@ is not a compilation unit description."
+        Location.print_filename filename
   | Corrupted_unit_info filename ->
-      fprintf ppf "Corrupted compilation unit description@ %s" filename
+      fprintf ppf "Corrupted compilation unit description@ %a"
+        Location.print_filename filename
   | Illegal_renaming(modname, filename) ->
-      fprintf ppf "%s@ contains the description for unit@ %s" filename modname
+      fprintf ppf "%a@ contains the description for unit@ %s"
+        Location.print_filename filename modname

diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli
index 4d43e1f8f2cd0f282292c8e9572c6d9b42351250..3e4d83e20e5b3b2a870de19bccda175c72142099 100644 (file)
--- a/asmcomp/compilenv.mli
+++ b/asmcomp/compilenv.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -51,9 +51,13 @@ val need_send_fun: int -> unit
         (* Record the need of a currying (resp. application,
            message sending) function with the given arity *)
 
+val new_const_symbol : unit -> string
+val new_const_label : unit -> int
+val new_structured_constant : Lambda.structured_constant -> bool -> string
+val structured_constants : unit -> (string * bool * Lambda.structured_constant) list
 
 val read_unit_info: string -> unit_infos * Digest.t
-        (* Read infos and CRC from a [.cmx] file. *)
+        (* Read infos and MD5 from a [.cmx] file. *)
 val write_unit_info: unit_infos -> string -> unit
         (* Save the given infos in the given file *)
 val save_unit_info: string -> unit

diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml
index a7124e171bf233ec285baaf1791b497700769ce5..ab0f5c047a35ea83f1840488b30fe72ed7c9a5ef 100644 (file)
--- a/asmcomp/debuginfo.ml
+++ b/asmcomp/debuginfo.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -31,6 +31,9 @@ let none = {
   dinfo_char_end = 0
 }
 
+let is_none t =
+  t == none
+
 let to_string d =
   if d == none
   then ""
@@ -38,7 +41,7 @@ let to_string d =
            d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end
 
 let from_location kind loc =
-  if loc.loc_ghost then none else
+  if loc == Location.none then none else
   { dinfo_kind = kind;
     dinfo_file = loc.loc_start.pos_fname;
     dinfo_line = loc.loc_start.pos_lnum;
@@ -50,3 +53,4 @@ let from_location kind loc =
 
 let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc
 let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc
+

diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli
index c3c9c406e4eaf6fb8782e11b60102774856d0eaf..cf6179cd37a01d03fd46b709cb7dcdbdc48ae90b 100644 (file)
--- a/asmcomp/debuginfo.mli
+++ b/asmcomp/debuginfo.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -22,6 +22,8 @@ type t = {
 
 val none: t
 
+val is_none: t -> bool
+
 val to_string: t -> string
 
 val from_location: kind -> Location.t -> t

diff --git a/asmcomp/emit.mli b/asmcomp/emit.mli
index ab7657af9ac0414186eca6350b59bc6d1db2d2f4..e2ff68ffcd97b2c178496064d2825b61bac5ff38 100644 (file)
--- a/asmcomp/emit.mli
+++ b/asmcomp/emit.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml
index d4db78ad75b88b6d0c064078011f8d7eadf23a66..712b848f7e1efab7a75dfe8645e9ee25446468fa 100644 (file)
--- a/asmcomp/emitaux.ml
+++ b/asmcomp/emitaux.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -114,6 +114,36 @@ let emit_float32_directive directive f =
   let x = Int32.bits_of_float (float_of_string f) in
   emit_printf "\t%s\t0x%lx\n" directive x
 
+(* Emit debug information *)
+
+(* This assoc list is expected to be very short *)
+let file_pos_nums =
+  (ref [] : (string * int) list ref)
+
+(* Number of files *)
+let file_pos_num_cnt = ref 1
+
+(* We only diplay .file if the file has not been seen before. We
+   display .loc for every instruction. *)
+let emit_debug_info dbg =
+  let line = dbg.Debuginfo.dinfo_line in
+  let file_name = dbg.Debuginfo.dinfo_file in
+  if !Clflags.debug && not (Debuginfo.is_none dbg) then (
+    let file_num =
+      try List.assoc file_name !file_pos_nums
+      with Not_found ->
+        let file_num = !file_pos_num_cnt in
+        incr file_pos_num_cnt;
+        emit_string "  .file   ";
+        emit_int file_num; emit_char ' ';
+        emit_string_literal file_name; emit_char '\n';
+        file_pos_nums := (file_name,file_num) :: !file_pos_nums;
+        file_num in
+    emit_string "      .loc    ";
+    emit_int file_num; emit_char '     ';
+    emit_int line; emit_char '\n'
+  )
+
 (* Record live pointers at call points *)
 
 type frame_descr =
@@ -189,3 +219,23 @@ let is_generic_function name =
   List.exists
     (fun p -> isprefix p name)
     ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"]
+
+(* CFI directives *)
+
+let is_cfi_enabled () =
+  !Clflags.debug && Config.asm_cfi_supported
+
+let cfi_startproc () =
+  if is_cfi_enabled () then
+    emit_string "      .cfi_startproc\n"
+
+let cfi_endproc () =
+  if is_cfi_enabled () then
+    emit_string "      .cfi_endproc\n"
+
+let cfi_adjust_cfa_offset n =
+  if is_cfi_enabled () then
+  begin
+    emit_string "      .cfi_adjust_cfa_offset  "; emit_int n; emit_string "\n";
+  end
+ 

diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli
index 4f666be736ad3e3f98cc377f1b628ecf770926c0..dd2f5b8c89689401eeba012f2faaa42dbffcb937 100644 (file)
--- a/asmcomp/emitaux.mli
+++ b/asmcomp/emitaux.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -29,6 +29,8 @@ val emit_float64_directive: string -> string -> unit
 val emit_float64_split_directive: string -> string -> unit
 val emit_float32_directive: string -> string -> unit
 
+val emit_debug_info: Debuginfo.t -> unit
+
 type frame_descr =
   { fd_lbl: int;                        (* Return address *)
     fd_frame_size: int;                 (* Size of stack frame *)
@@ -50,3 +52,7 @@ type emit_frame_actions =
 val emit_frames: emit_frame_actions -> unit
 
 val is_generic_function: string -> bool
+
+val cfi_startproc : unit -> unit
+val cfi_endproc : unit -> unit
+val cfi_adjust_cfa_offset : int -> unit

diff --git a/asmcomp/hppa/arch.ml b/asmcomp/hppa/arch.ml
deleted file mode 100644 (file)
index eb2e193..0000000
--- a/asmcomp/hppa/arch.ml
+++ /dev/null
@@ -1,73 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Specific operations for the HP PA-RISC processor *)
-
-open Misc
-open Format
-
-(* Machine-specific command-line options *)
-
-let command_line_options = []
-
-(* Specific operations *)
-
-type specific_operation =
-    Ishift1add
-  | Ishift2add
-  | Ishift3add
-
-(* Addressing modes *)
-
-type addressing_mode =
-    Ibased of string * int              (* symbol + displ *)
-  | Iindexed of int                     (* reg + displ *)
-
-(* Sizes, endianness *)
-
-let big_endian = true
-
-let size_addr = 4
-let size_int = 4
-let size_float = 8
-
-(* Operations on addressing modes *)
-
-let identity_addressing = Iindexed 0
-
-let offset_addressing addr delta =
-  match addr with
-    Ibased(s, n) -> Ibased(s, n + delta)
-  | Iindexed n -> Iindexed(n + delta)
-
-let num_args_addressing = function
-    Ibased(s, n) -> 0
-  | Iindexed n -> 1
-
-(* Printing operations and addressing modes *)
-
-let print_addressing printreg addr ppf arg =
-  match addr with
-  | Ibased(s, n) ->
-      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
-      fprintf ppf "\"%s\"%s" s idx
-  | Iindexed n ->
-      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
-      fprintf ppf "%a%s" printreg arg.(0) idx
-
-let print_specific_operation printreg op ppf arg =
-  match op with
-  | Ishift1add -> fprintf ppf "%a << 1 + %a" printreg arg.(0) printreg arg.(1)
-  | Ishift2add -> fprintf ppf "%a << 2 + %a" printreg arg.(0) printreg arg.(1)
-  | Ishift3add -> fprintf ppf "%a << 3 + %a" printreg arg.(0) printreg arg.(1)

diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp
deleted file mode 100644 (file)
index b697a33..0000000
--- a/asmcomp/hppa/emit.mlp
+++ /dev/null
@@ -1,1042 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Emission of HP PA-RISC assembly code *)
-
-(* Must come before open Reg... *)
-module StringSet =
-  Set.Make(struct
-    type t = string
-    let compare = compare
-  end)
-
-open Location
-open Misc
-open Cmm
-open Arch
-open Proc
-open Reg
-open Mach
-open Linearize
-open Emitaux
-
-(* Tradeoff between code size and code speed *)
-
-let fastcode_flag = ref true
-
-(* Layout of the stack *)
-(* Always keep the stack 8-aligned. *)
-
-let stack_offset = ref 0
-
-let frame_size () =
-  let size =
-    !stack_offset +
-    4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
-    (if !contains_calls then 4 else 0) in
-  Misc.align size 8
-
-let slot_offset loc cl =
-  match loc with
-    Incoming n -> -frame_size() - n
-  | Local n ->
-      if cl = 0
-      then - !stack_offset - num_stack_slots.(1) * 8 - n * 4 - 4
-      else - !stack_offset - n * 8 - 8
-  | Outgoing n -> -n
-
-(* Output a label *)
-
-let emit_label lbl =
-  emit_string "L$"; emit_int lbl
-
-(* Output a symbol *)
-
-let emit_symbol s =
-  Emitaux.emit_symbol '$' s
-
-(* Output a pseudo-register *)
-
-let emit_reg r =
-  match r.loc with
-    Reg r -> emit_string (register_name r)
-  | _ -> assert false
-
-(* Output low address / high address prefixes *)
-
-let low_prefix = "RR%"
-let high_prefix = "LR%"
-
-let is_immediate n = (n < 16) && (n >= -16) (* 5 bits *)
-
-let emit_int_low n = emit_string low_prefix; emit_int n
-let emit_int_high n = emit_string high_prefix; emit_int n
-
-let emit_nativeint_low n = emit_string low_prefix; emit_nativeint n
-let emit_nativeint_high n = emit_string high_prefix; emit_nativeint n
-
-let emit_symbol_low s =
-  `RR%{emit_symbol s}-$global$`
-
-let load_symbol_high s =
-  `    addil   LR%{emit_symbol s}-$global$, %r27\n`
-
-let load_symbol_offset_high s ofs =
-  `    addil   LR%{emit_symbol s}-$global$+{emit_int ofs}, %r27\n`
-
-(* Record imported and defined symbols *)
-
-let used_symbols = ref StringSet.empty
-let defined_symbols = ref StringSet.empty
-let called_symbols = ref StringSet.empty
-
-let use_symbol s =
-  used_symbols := StringSet.add s !used_symbols
-let define_symbol s =
-  defined_symbols := StringSet.add s !defined_symbols
-let call_symbol s =
-  used_symbols := StringSet.add s !used_symbols;
-  called_symbols := StringSet.add s !called_symbols
-
-(* An external symbol is code if either it is branched to, or
-   it is one of the caml_apply* caml_curry* caml_tuplify* special functions. *)
-
-let code_imports = ["caml_apply"; "caml_curry"; "caml_tuplify"]
-
-let match_prefix s pref =
-  String.length s >= String.length pref
-  && String.sub s 0 (String.length pref) = pref
-
-let emit_import s =
-  if not(StringSet.mem s !defined_symbols) then begin
-    `  .import {emit_symbol s}`;
-    if StringSet.mem s !called_symbols
-    || List.exists (match_prefix s) code_imports
-    then `, code\n`
-    else `, data\n`
-  end
-
-let emit_imports () =
-  StringSet.iter emit_import !used_symbols;
-  used_symbols := StringSet.empty;
-  defined_symbols := StringSet.empty;
-  called_symbols := StringSet.empty
-
-(* Output an integer load / store *)
-
-let is_offset n = (n < 8192) && (n >= -8192) (* 14 bits *)
-
-let is_offset_native n =
-  n < Nativeint.of_int 8192 && n >= Nativeint.of_int (-8192)
-
-let emit_load instr addr arg dst =
-  match addr with
-    Ibased(s, 0) ->
-        use_symbol s;
-        load_symbol_high s;
-        `      {emit_string instr}     {emit_symbol_low s}(%r1), {emit_reg dst}\n`
-  | Ibased(s, ofs) ->
-        use_symbol s;
-        load_symbol_offset_high s ofs;
-        `      {emit_string instr}     {emit_symbol_low s}+{emit_int ofs}(%r1), {emit_reg dst}\n`
-  | Iindexed ofs ->
-      if is_offset ofs then
-        `      {emit_string instr}     {emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}\n`
-      else begin
-        `      addil   {emit_int_high ofs}, {emit_reg arg.(0)}\n`;
-        `      {emit_string instr}     {emit_int_low ofs}(%r1), {emit_reg dst}\n`
-      end
-
-let emit_store instr addr arg src =
-  match addr with
-    Ibased(s, 0) ->
-        use_symbol s;
-        load_symbol_high s;
-        `      {emit_string instr}     {emit_reg src}, {emit_symbol_low s}(%r1)\n`
-  | Ibased(s, ofs) ->
-        use_symbol s;
-        load_symbol_offset_high s ofs;
-        `      {emit_string instr}     {emit_reg src}, {emit_symbol_low s}+{emit_int ofs}(%r1)\n`
-  | Iindexed ofs ->
-      if is_offset ofs then
-        `      {emit_string instr}     {emit_reg src}, {emit_int ofs}({emit_reg arg.(1)})\n`
-      else begin
-        `      addil   {emit_int_high ofs}, {emit_reg arg.(0)}\n`;
-        `      {emit_string instr}     {emit_reg src}, {emit_int_low ofs}(%r1)\n`
-      end
-
-(* Output a floating-point load / store *)
-
-let emit_float_load addr arg dst doubleword =
-  match addr with
-    Ibased(s, 0) ->
-        use_symbol s;
-        load_symbol_high s;
-        `      ldo     {emit_symbol_low s}(%r1), %r1\n`;
-        `      fldws   0(%r1), {emit_reg dst}L\n`;
-        if doubleword then
-          `    fldws   4(%r1), {emit_reg dst}R\n`
-  | Ibased(s, ofs) ->
-        use_symbol s;
-        load_symbol_offset_high s ofs;
-        `      ldo     {emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`;
-        `      fldws   0(%r1), {emit_reg dst}L\n`;
-        if doubleword then
-          `    fldws   4(%r1), {emit_reg dst}R\n`
-  | Iindexed ofs ->
-      if is_immediate ofs && (is_immediate (ofs+4) || not doubleword)
-      then begin
-        `      fldws   {emit_int ofs}({emit_reg arg.(0)}), {emit_reg dst}L\n`;
-        if doubleword then
-          `    fldws   {emit_int (ofs+4)}({emit_reg arg.(0)}), {emit_reg dst}R\n`
-      end else begin
-        if is_offset ofs then
-          `    ldo     {emit_int ofs}({emit_reg arg.(0)}), %r1\n`
-        else begin
-          `    addil   {emit_int_high ofs}, {emit_reg arg.(0)}\n`;
-          `    ldo     {emit_int_low ofs}(%r1), %r1\n`
-        end;
-        `      fldws   0(%r1), {emit_reg dst}L\n`;
-        if doubleword then
-          `    fldws   4(%r1), {emit_reg dst}R\n`
-      end
-
-let emit_float_store addr arg src doubleword =
-  match addr with
-    Ibased(s, 0) ->
-        use_symbol s;
-        load_symbol_high s;
-        `      ldo     {emit_symbol_low s}(%r1), %r1\n`;
-        `      fstws   {emit_reg src}L, 0(%r1)\n`;
-        if doubleword then
-          `    fstws   {emit_reg src}R, 4(%r1)\n`
-  | Ibased(s, ofs) ->
-        use_symbol s;
-        load_symbol_offset_high s ofs;
-        `      ldo     {emit_symbol_low s}+{emit_int ofs}(%r1), %r1\n`;
-        `      fstws   {emit_reg src}L, 0(%r1)\n`;
-        if doubleword then
-          `    fstws   {emit_reg src}R, 4(%r1)\n`
-  | Iindexed ofs ->
-      if is_immediate ofs && (is_immediate (ofs+4) || not doubleword)
-      then begin
-        `      fstws   {emit_reg src}L, {emit_int ofs}({emit_reg arg.(1)})\n`;
-        if doubleword then
-          `    fstws   {emit_reg src}R, {emit_int(ofs+4)}({emit_reg arg.(1)})\n`
-      end else begin
-        if is_offset ofs then
-          `    ldo     {emit_int ofs}({emit_reg arg.(1)}), %r1\n`
-        else begin
-          `    addil   {emit_int_high ofs}, {emit_reg arg.(1)}\n`;
-          `    ldo     {emit_int_low ofs}(%r1), %r1\n`
-        end;
-        `      fstws   {emit_reg src}L, 0(%r1)\n`;
-        if doubleword then
-          `    fstws   {emit_reg src}R, 4(%r1)\n`
-      end
-
-(* Output an align directive. *)
-
-let emit_align n =
-  `    .align  {emit_int n}\n`
-
-(* Record live pointers at call points *)
-
-type frame_descr =
-  { fd_lbl: int;                        (* Return address *)
-    fd_frame_size: int;                 (* Size of stack frame *)
-    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
-
-let frame_descriptors = ref([] : frame_descr list)
-
-let record_frame live =
-  let lbl = new_label() in
-  let live_offset = ref [] in
-  Reg.Set.iter
-    (function
-        {typ = Addr; loc = Reg r} ->
-          live_offset := ((r lsl 1) + 1) :: !live_offset
-      | {typ = Addr; loc = Stack s} as reg ->
-          live_offset := slot_offset s (register_class reg) :: !live_offset
-      | _ -> ())
-    live;
-  frame_descriptors :=
-    { fd_lbl = lbl;
-      fd_frame_size = frame_size();
-      fd_live_offset = !live_offset } :: !frame_descriptors;
-  `{emit_label lbl}:\n`
-
-let emit_frame fd =
-  `    .long   {emit_label fd.fd_lbl} + 3\n`;
-  `    .short  {emit_int fd.fd_frame_size}\n`;
-  `    .short  {emit_int (List.length fd.fd_live_offset)}\n`;
-  List.iter
-    (fun n ->
-      `        .short  {emit_int n}\n`)
-    fd.fd_live_offset;
-  emit_align 4
-
-(* Record floating-point constants *)
-
-let float_constants = ref ([] : (int * string) list)
-
-let emit_float_constants () =
-  if Config.system = "hpux" then begin
-    `  .space  $TEXT$\n`;
-    `  .subspa $LIT$\n`
-  end else
-    `  .text\n`;
-  emit_align 8;
-  List.iter
-    (fun (lbl, cst) ->
-      `{emit_label lbl}:`;
-      emit_float64_split_directive ".long" cst)
-    !float_constants;
-  float_constants := []
-
-(* Describe the registers used to pass arguments to a C function *)
-
-let describe_call arg =
-  `    .CALL   RTNVAL=NO`;
-  let pos = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    if !pos < 4 then begin
-      match arg.(i).typ with
-        Float -> `, ARGW{emit_int !pos}=FR, ARGW{emit_int(!pos + 1)}=FU`;
-                 pos := !pos + 2
-      | _     -> `, ARGW{emit_int !pos}=GR`;
-                 pos := !pos + 1
-    end
-  done;
-  `\n`
-
-(* Output a function call *)
-
-let emit_call s retreg =
-  call_symbol s;
-  `    bl      {emit_symbol s}, {emit_string retreg}\n`
-
-(* Names of various instructions *)
-
-let name_for_int_operation = function
-    Iadd -> "add"
-  | Isub -> "sub"
-  | Iand -> "and"
-  | Ior -> "or"
-  | Ixor -> "xor"
-  | _ -> assert false
-
-let name_for_float_operation = function
-    Iaddf -> "fadd,dbl"
-  | Isubf -> "fsub,dbl"
-  | Imulf -> "fmpy,dbl"
-  | Idivf -> "fdiv,dbl"
-  | _ -> assert false
-
-let name_for_specific_operation = function
-    Ishift1add -> "sh1add"
-  | Ishift2add -> "sh2add"
-  | Ishift3add -> "sh3add"
-
-let name_for_int_comparison = function
-    Isigned Ceq -> "="      | Isigned Cne -> "<>"
-  | Isigned Cle -> "<="     | Isigned Cgt -> ">"
-  | Isigned Clt -> "<"      | Isigned Cge -> ">="
-  | Iunsigned Ceq -> "="    | Iunsigned Cne -> "<>"
-  | Iunsigned Cle -> "<<="  | Iunsigned Cgt -> ">>"
-  | Iunsigned Clt -> "<<"   | Iunsigned Cge -> ">>="
-
-let name_for_float_comparison cmp neg =
-  match cmp with
-    Ceq -> if neg then "=" else "!="
-  | Cne -> if neg then "!=" else "="
-  | Cle -> if neg then "<=" else "!<="
-  | Cgt -> if neg then ">" else "!>"
-  | Clt -> if neg then "<" else "!<"
-  | Cge -> if neg then ">=" else "!>="
-
-let negate_int_comparison = function
-    Isigned cmp -> Isigned(Cmm.negate_comparison cmp)
-  | Iunsigned cmp -> Iunsigned(Cmm.negate_comparison cmp)
-
-let swap_int_comparison = function
-    Isigned cmp -> Isigned(Cmm.swap_comparison cmp)
-  | Iunsigned cmp -> Iunsigned(Cmm.swap_comparison cmp)
-
-
-(* Output the assembly code for an instruction *)
-
-(* Name of current function *)
-let function_name = ref ""
-(* Entry point for tail recursive calls *)
-let tailrec_entry_point = ref 0
-(* Label of trap for out-of-range accesses *)
-let range_check_trap = ref 0
-
-let rec emit_instr i dslot =
-    match i.desc with
-      Lend -> ()
-    | Lop(Imove | Ispill | Ireload) ->
-        let src = i.arg.(0) and dst = i.res.(0) in
-        begin match (src, dst) with
-            {loc = Reg rs; typ = (Int | Addr)}, {loc = Reg rd} ->
-              `        copy    {emit_reg src}, {emit_reg dst}\n`
-          | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
-              `        fcpy,dbl {emit_reg src}, {emit_reg dst}\n`
-          | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} ->
-              let ofs = slot_offset sd 0 in
-              `        stw     {emit_reg src}, {emit_int ofs}(%r30)\n`
-          | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
-              let ofs = slot_offset sd 1 in
-              if is_immediate ofs then
-              `        fstds   {emit_reg src}, {emit_int ofs}(%r30)\n`
-              else begin
-              `        ldo     {emit_int ofs}(%r30), %r1\n`;
-              `        fstds   {emit_reg src}, 0(%r1)\n`
-              end
-          | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} ->
-              let ofs = slot_offset ss 0 in
-              `        ldw     {emit_int ofs}(%r30), {emit_reg dst}\n`
-          | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
-              let ofs = slot_offset ss 1 in
-              if is_immediate ofs then
-              `        fldds   {emit_int ofs}(%r30), {emit_reg dst}\n`
-              else begin
-              `        ldo     {emit_int ofs}(%r30), %r1\n`;
-              `        fldds   0(%r1), {emit_reg dst}\n`
-              end
-          | (_, _) ->
-              assert false
-        end
-    | Lop(Iconst_int n) ->
-        if is_offset_native n then
-          `    ldi     {emit_nativeint n}, {emit_reg i.res.(0)}\n`
-        else begin
-          `    ldil    {emit_nativeint_high n}, {emit_reg i.res.(0)}\n`;
-          `    ldo     {emit_nativeint_low n}({emit_reg i.res.(0)}), {emit_reg i.res.(0)}\n`
-        end
-    | Lop(Iconst_float s) ->
-        let lbl = new_label() in
-        float_constants := (lbl, s) :: !float_constants;
-        `      ldil    {emit_string high_prefix}{emit_label lbl}, %r1\n`;
-        `      ldo     {emit_string low_prefix}{emit_label lbl}(%r1), %r1\n`;
-        `      fldds   0(%r1), {emit_reg i.res.(0)}\n`
-    | Lop(Iconst_symbol s) ->
-        use_symbol s;
-        load_symbol_high s;
-        `      ldo     {emit_symbol_low s}(%r1), {emit_reg i.res.(0)}\n`
-    | Lop(Icall_ind) ->
-        `      ble     0(4, {emit_reg i.arg.(0)})\n`; (* retaddr in %r31 *)
-        `      copy    %r31, %r2\n`; (* in delay slot: save retaddr in %r2 *)
-        record_frame i.live
-    | Lop(Icall_imm s) ->
-        emit_call s "%r2";
-        fill_delay_slot dslot;
-        record_frame i.live
-    | Lop(Itailcall_ind) ->
-        let n = frame_size() in
-        `      bv      0({emit_reg i.arg.(0)})\n`;
-        if !contains_calls (* in delay slot *)
-        then ` ldwm    {emit_int(-n)}(%r30), %r2\n`
-        else ` ldo     {emit_int(-n)}(%r30), %r30\n`
-    | Lop(Itailcall_imm s) ->
-        let n = frame_size() in
-        if s = !function_name then begin
-          `    b,n     {emit_label !tailrec_entry_point}\n`
-        end else begin
-          emit_call s "%r0";
-          if !contains_calls (* in delay slot *)
-          then `       ldwm    {emit_int(-n)}(%r30), %r2\n`
-          else `       ldo     {emit_int(-n)}(%r30), %r30\n`
-        end
-    | Lop(Iextcall(s, alloc)) ->
-        call_symbol s;
-        if alloc then begin
-          `    ldil    LR%{emit_symbol s}, %r22\n`;
-          describe_call i.arg;
-          emit_call "caml_c_call" "%r2";
-          `    ldo     RR%{emit_symbol s}(%r22), %r22\n`;  (* in delay slot *)
-          record_frame i.live
-        end else begin
-          describe_call i.arg;
-          emit_call s "%r2";
-          fill_delay_slot dslot
-        end
-    | Lop(Istackoffset n) ->
-        `      ldo     {emit_int n}(%r30), %r30\n`;
-        stack_offset := !stack_offset + n
-    | Lop(Iload(chunk, addr)) ->
-       let dest = i.res.(0) in
-        begin match chunk with
-          Byte_unsigned ->
-            emit_load "ldb" addr i.arg dest
-        | Byte_signed ->
-            emit_load "ldb" addr i.arg dest;
-            `  extrs   {emit_reg dest}, 31, 8, {emit_reg dest}\n`
-        | Sixteen_unsigned ->
-            emit_load "ldh" addr i.arg dest
-        | Sixteen_signed ->
-            emit_load "ldh" addr i.arg dest;
-            `  extrs   {emit_reg dest}, 31, 16, {emit_reg dest}\n`
-        | Single ->
-            emit_float_load addr i.arg dest false;
-            `  fcnvff,sgl,dbl {emit_reg dest}L, {emit_reg dest}\n`
-        | Double | Double_u ->
-            emit_float_load addr i.arg dest true
-        | _ ->
-            emit_load "ldw" addr i.arg dest
-        end
-    | Lop(Istore(chunk, addr)) ->
-        let src = i.arg.(0) in
-        begin match chunk with
-          Byte_unsigned | Byte_signed ->
-            emit_store "stb" addr i.arg src
-        | Sixteen_unsigned | Sixteen_signed ->
-            emit_store "sth" addr i.arg src
-        | Single ->
-            `  fcnvff,dbl,sgl  {emit_reg src}, %fr31L\n`;
-            emit_float_store addr i.arg (phys_reg 127) (* %fr31 *) false
-        | Double | Double_u ->
-            emit_float_store addr i.arg src true
-        | _ ->
-            emit_store "stw" addr i.arg src
-        end
-    | Lop(Ialloc n) ->
-        if !fastcode_flag then begin
-          let lbl_cont = new_label() in
-          `    ldw     0(%r4), %r1\n`;
-          `    ldo     {emit_int (-n)}(%r3), %r3\n`;
-          `    comb,>>= %r3, %r1, {emit_label lbl_cont}\n`;
-          `    addi    4, %r3, {emit_reg i.res.(0)}\n`; (* in delay slot *)
-          emit_call "caml_call_gc" "%r2";
-          (* Cannot use %r1 to pass size, since clobbered by glue call code *)
-          `    ldi     {emit_int n}, %r29\n`; (* in delay slot *)
-          record_frame i.live;
-          `    addi    4, %r3, {emit_reg i.res.(0)}\n`;
-          `{emit_label lbl_cont}:\n`
-        end else begin
-          emit_call "caml_allocN" "%r2";
-          (* Cannot use %r1 either *)
-          `    ldi     {emit_int n}, %r29\n`; (* in delay slot *)
-          record_frame i.live;
-          `    addi    4, %r3, {emit_reg i.res.(0)}\n`
-        end
-    | Lop(Iintop Imul) ->
-        `      stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`;
-        `      stw     {emit_reg i.arg.(1)}, -4(%r30)\n`;
-        `      fldws   -8(%r30), %fr31L\n`;
-        `      fldws   -4(%r30), %fr31R\n`;
-        `      xmpyu   %fr31L, %fr31R, %fr31\n`;
-        `      fstws   %fr31R, -8(%r30)\n`; (* poor scheduling *)
-        `      ldws,mb -8(%r30), {emit_reg i.res.(0)}\n`
-    | Lop(Iintop Idiv) ->
-        (* Arguments are assumed to be in %r26 and %r25, result in %r29 *)
-        `      bl      $$divI, %r31\n`;
-        fill_delay_slot dslot
-    | Lop(Iintop Imod) ->
-        (* Arguments are assumed to be in %r26 and %r25, result in %r29 *)
-        `      bl      $$remI, %r31\n`;
-        fill_delay_slot dslot
-    | Lop(Iintop Ilsl) ->
-        `      subi    31, {emit_reg i.arg.(1)}, %r1\n`;
-        `      mtsar   %r1\n`;
-        `      zvdep   {emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop Ilsr) ->
-        `      mtsar   {emit_reg i.arg.(1)}\n`;
-        `      vshd    %r0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop Iasr) ->
-        `      subi    31, {emit_reg i.arg.(1)}, %r1\n`;
-        `      mtsar   %r1\n`;
-        `      vextrs  {emit_reg i.arg.(0)}, 32, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop(Icomp cmp)) ->
-        let comp = name_for_int_comparison(negate_int_comparison cmp) in
-        `      comclr,{emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`;
-        `      ldi     1, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop Icheckbound) ->
-        if !range_check_trap = 0 then range_check_trap := new_label();
-        `      comclr,>> {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, %r0\n`;
-        `      b,n     {emit_label !range_check_trap}\n`
-    | Lop(Iintop op) ->
-        let instr = name_for_int_operation op in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Iadd, n)) ->
-        `      addi    {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Isub, n)) ->
-        `      addi    {emit_int(-n)}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Idiv, n)) ->
-        let l = Misc.log2 n in
-        `      comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`;
-       if not (l = 0) then
-          `    zdepi   -1, 31, {emit_int l}, %r1\n`
-       else
-         `     xor     %r1, %r1, %r1\n`;
-        `      add     {emit_reg i.arg.(0)}, %r1, %r1\n`;
-        `      extrs   %r1, {emit_int(31-l)}, {emit_int(32-l)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Imod, n)) ->
-        let l = Misc.log2 n in
-        `      comclr,>= {emit_reg i.arg.(0)}, %r0, %r1\n`;
-       if not (l = 0) then
-          `    zdepi   -1, 31, {emit_int l}, %r1\n`
-       else
-         `     xor     %r1, %r1, %r1\n`;
-        `      add     {emit_reg i.arg.(0)}, %r1, %r1\n`;
-        `      depi    0, 31, {emit_int l}, %r1\n`;
-        `      sub     {emit_reg i.arg.(0)}, %r1, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Ilsl, n)) ->
-        let n = n land 31 in
-        `      zdep    {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Ilsr, n)) ->
-        let n = n land 31 in
-        `      extru   {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Iasr, n)) ->
-        let n = n land 31 in
-        `      extrs   {emit_reg i.arg.(0)}, {emit_int(31-n)}, {emit_int(32-n)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Icomp cmp, n)) ->
-        let comp = name_for_int_comparison(negate_int_comparison(swap_int_comparison cmp)) in
-        `      comiclr,{emit_string comp} {emit_int n}, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`;
-        `      ldi     1, {emit_reg i.res.(0)}\n`
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-        if !range_check_trap = 0 then range_check_trap := new_label();
-        `      comiclr,<< {emit_int n}, {emit_reg i.arg.(0)}, %r0\n`;
-        `      b,n     {emit_label !range_check_trap}\n`
-    | Lop(Iintop_imm(op, n)) ->
-        assert false
-    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
-        let instr = name_for_float_operation op in
-        `      {emit_string instr} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lop(Inegf) ->
-        `      fsub,dbl 0, {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iabsf) ->
-        `      fabs,dbl {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Ifloatofint) ->
-        `      stws,ma {emit_reg i.arg.(0)}, 8(%r30)\n`;
-        `      fldws,mb -8(%r30), %fr31L\n`;
-        `      fcnvxf,sgl,dbl %fr31L, {emit_reg i.res.(0)}\n`
-    | Lop(Iintoffloat) ->
-        `      fcnvfxt,dbl,sgl {emit_reg i.arg.(0)}, %fr31L\n`;
-        `      fstws,ma %fr31L, 8(%r30)\n`;
-        `      ldws,mb -8(%r30), {emit_reg i.res.(0)}\n`
-    | Lop(Ispecific sop) ->
-        let instr = name_for_specific_operation sop in
-        `      {emit_string instr}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
-    | Lreloadretaddr ->
-        let n = frame_size() in
-        `      ldw     {emit_int(-n)}(%r30), %r2\n`
-    | Lreturn ->
-        let n = frame_size() in
-        `      bv      0(%r2)\n`;
-        `      ldo     {emit_int(-n)}(%r30), %r30\n` (* in delay slot *)
-    | Llabel lbl ->
-        `{emit_label lbl}:\n`
-    | Lbranch lbl ->
-        begin match dslot with
-            None ->
-              `        b,n     {emit_label lbl}\n`
-          | Some i ->
-              `        b       {emit_label lbl}\n`;
-              emit_instr i None
-        end
-    | Lcondbranch(tst, lbl) ->
-        begin match tst with
-          Itruetest ->
-            emit_comib "<>" "=" 0 i.arg lbl dslot
-        | Ifalsetest ->
-            emit_comib "=" "<>" 0 i.arg lbl dslot
-        | Iinttest cmp ->
-            let comp = name_for_int_comparison cmp
-            and negcomp =
-              name_for_int_comparison(negate_int_comparison cmp) in
-            emit_comb comp negcomp i.arg lbl dslot
-        | Iinttest_imm(cmp, n) ->
-            let scmp = swap_int_comparison cmp in
-            let comp = name_for_int_comparison scmp
-            and negcomp =
-              name_for_int_comparison(negate_int_comparison scmp) in
-            emit_comib comp negcomp n i.arg lbl dslot
-        | Ifloattest(cmp, neg) ->
-            let comp = name_for_float_comparison cmp neg in
-            `  fcmp,dbl,{emit_string comp}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-            `  ftest\n`;
-            `  b       {emit_label lbl}\n`;
-            fill_delay_slot dslot
-        | Ioddtest ->
-            emit_comib "OD" "EV" 0 i.arg lbl dslot
-        | Ieventest ->
-            emit_comib "EV" "OD" 0 i.arg lbl dslot
-        end
-  | Lcondbranch3(lbl0, lbl1, lbl2) ->
-        begin match lbl0 with
-          None -> ()
-        | Some lbl -> emit_comib "=" "<>" 0 i.arg lbl None
-        end;
-        begin match lbl1 with
-          None -> ()
-        | Some lbl -> emit_comib "=" "<>" 1 i.arg lbl None
-        end;
-        begin match lbl2 with
-          None -> ()
-        | Some lbl -> emit_comib "=" "<>" 2 i.arg lbl None
-        end
-    | Lswitch jumptbl ->
-        `      blr     {emit_reg i.arg.(0)}, 0\n`;
-        fill_delay_slot dslot;
-        for i = 0 to Array.length jumptbl - 1 do
-          `    b       {emit_label jumptbl.(i)}\n`;
-          `    nop\n`
-        done
-    | Lsetuptrap lbl ->
-        `      bl      {emit_label lbl}, %r1\n`;
-        fill_delay_slot dslot
-    | Lpushtrap ->
-        stack_offset := !stack_offset + 8;
-        `      stws,ma %r5, 8(%r30)\n`;
-        `      stw     %r1, -4(%r30)\n`;
-        `      copy    %r30, %r5\n`
-    | Lpoptrap ->
-        `      ldws,mb -8(%r30), %r5\n`;
-        stack_offset := !stack_offset - 8
-    | Lraise ->
-        `      ldw     -4(%r5), %r1\n`;
-        `      copy    %r5, %r30\n`;
-        `      bv      0(%r1)\n`;
-        `      ldws,mb -8(%r30), %r5\n` (* in delay slot *)
-
-and fill_delay_slot = function
-    None -> `  nop\n`
-  | Some i -> emit_instr i None
-
-and emit_delay_slot = function
-    None -> ()
-  | Some i -> emit_instr i None
-
-and emit_comb comp negcomp arg lbl dslot =
-  if lbl >= 0 then begin
-    `  comb,{emit_string comp} {emit_reg arg.(0)}, {emit_reg arg.(1)}, {emit_label lbl}\n`;
-    fill_delay_slot dslot
-  end else begin
-    emit_delay_slot dslot;
-    `  comclr,{emit_string negcomp}    {emit_reg arg.(0)}, {emit_reg arg.(1)}, %r0\n`;
-    `  b,n     {emit_label (-lbl)}\n`
-  end
-
-and emit_comib comp negcomp cst arg lbl dslot =
-  if lbl >= 0 then begin
-    `  comib,{emit_string comp}        {emit_int cst}, {emit_reg arg.(0)}, {emit_label lbl}\n`;
-    fill_delay_slot dslot
-  end else begin
-    emit_delay_slot dslot;
-    `  comiclr,{emit_string negcomp}   {emit_int cst}, {emit_reg arg.(0)}, %r0\n`;
-    `  b,n     {emit_label (-lbl)}\n`
-  end
-
-(* Checks if a pseudo-instruction expands to exactly one machine instruction
-   that does not branch. *)
-
-let is_one_instr i =
-  match i.desc with
-    Lop op ->
-      begin match op with
-        Imove | Ispill | Ireload ->
-          begin match (i.arg.(0), i.res.(0)) with
-            ({typ = Float; loc = Stack s}, _) -> is_immediate(slot_offset s 1)
-          | (_, {typ = Float; loc = Stack s}) -> is_immediate(slot_offset s 1)
-          | (_, _) -> true
-          end
-      | Iconst_int n -> is_offset_native n
-      | Istackoffset _ -> true
-      | Iload(_, Iindexed n) -> i.res.(0).typ <> Float & is_offset n
-      | Istore(_, Iindexed n) -> i.arg.(0).typ <> Float & is_offset n
-      | Iintop(Iadd | Isub | Iand | Ior | Ixor) -> true
-      | Iintop_imm((Iadd | Isub | Ilsl | Ilsr | Iasr), _) -> true
-      | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf -> true
-      | Ispecific _ -> true
-      | _ -> false
-      end
-  | Lreloadretaddr -> true
-  | _ -> false
-
-let no_interference res arg =
-  try
-    for i = 0 to Array.length arg - 1 do
-      for j = 0 to Array.length res - 1 do
-        if arg.(i).loc = res.(j).loc then raise Exit
-      done
-    done;
-    true
-  with Exit ->
-    false
-
-(* Emit a sequence of instructions, trying to fill delay slots for branches *)
-
-let rec emit_all i =
-  match i with
-    {desc = Lend} -> ()
-  | {next = {desc = Lop(Icall_imm _)
-                  | Lop(Iextcall(_, false))
-                  | Lop(Iintop(Idiv | Imod))
-                  | Lbranch _
-                  | Lsetuptrap _ }}
-    when is_one_instr i ->
-      emit_instr i.next (Some i);
-      emit_all i.next.next
-  | {next = {desc = Lcondbranch(_, _) | Lswitch _}}
-    when is_one_instr i & no_interference i.res i.next.arg ->
-      emit_instr i.next (Some i);
-      emit_all i.next.next
-  | _ ->
-      emit_instr i None;
-      emit_all i.next
-
-(* Estimate the size of an instruction, in actual HPPA instructions *)
-
-let is_float_stack r =
-  match r with {loc = Stack _; typ = Float} -> true | _ -> false
-
-let sizeof_instr i =
-  match i.desc with
-    Lend -> 0
-  | Lop op ->
-      begin match op with
-        Imove | Ispill | Ireload ->
-          if is_float_stack i.arg.(0) || is_float_stack i.res.(0)
-          then 2 (* ldo/fxxx *) else 1
-      | Iconst_int n ->
-          if is_offset_native n then 1 else 2 (* ldi or ldil/ldo *)
-      | Iconst_float _ -> 3 (* ldil/ldo/fldds *)
-      | Iconst_symbol _ -> 2 (* addil/ldo *)
-      | Icall_ind -> 2 (* ble/copy *)
-      | Icall_imm _ -> 2 (* bl/nop *)
-      | Itailcall_ind -> 2 (* bv/ldwm *)
-      | Itailcall_imm _ -> 2 (* bl/ldwm *)
-      | Iextcall(_, alloc) ->
-          if alloc then 3 (* ldil/bl/ldo *) else 2 (* bl/nop *)
-      | Istackoffset _ -> 1 (* ldo *)
-      | Iload(chunk, addr) ->
-          if i.res.(0).typ = Float
-          then 4 (* addil/ldo/fldws/fldws *)
-          else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2)
-             + (match chunk with Byte_signed -> 1 | Sixteen_signed -> 1 | _ -> 0)
-      | Istore(chunk, addr) ->
-          if i.arg.(0).typ = Float
-          then 4 (* addil/ldo/fstws/fstws *)
-          else (match addr with Iindexed ofs when is_offset ofs -> 1 | _ -> 2)
-      | Ialloc _ -> if !fastcode_flag then 7 else 3
-      | Iintop Imul -> 7
-      | Iintop(Idiv | Imod) -> 3 (* ldil/ble/nop *)
-      | Iintop Ilsl -> 3 (* subi/mtsar/zvdep *)
-      | Iintop Ilsr -> 2 (* mtsar/vshd *)
-      | Iintop Iasr -> 3 (* subi/mtsar/vextrs *)
-      | Iintop(Icomp _) -> 2 (* comclr/ldi *)
-      | Iintop Icheckbound -> 2 (* comclr/b,n *)
-      | Iintop _ -> 1
-      | Iintop_imm(Idiv, _) -> 4 (* comclr/zdepi/add/extrs *)
-      | Iintop_imm(Imod, _) -> 5 (* comclr/zdepi/add/extrs/sub *)
-      | Iintop_imm(Icomp _, _) -> 2 (* comiclr/ldi *)
-      | Iintop_imm(Icheckbound, _) -> 2 (* comiclr/b,n *)
-      | Iintop_imm(_, _) -> 1
-      | Ifloatofint -> 3 (* stws,ma/fldws,mb/fcnvxf *)
-      | Iintoffloat -> 3 (* fcnfxt/fstws/ldws *)
-      | _ (* Inegf|Iabsf|Iaddf|Isubf|Imulf|Idivf|Ispecific _ *) -> 1
-      end
-  | Lreloadretaddr -> 1
-  | Lreturn -> 2
-  | Llabel _ -> 0
-  | Lbranch _ -> 1 (* b,n *)
-  | Lcondbranch(Ifloattest(_, _), _) -> 4 (* fcmp/ftest/b/nop *)
-  | Lcondbranch(_, _) -> 2 (* comb/nop or comclr/b,n *)
-  | Lcondbranch3(_, _, _) -> 6 (* worst case: three comib/nop or comclr/b,n *)
-  | Lswitch tbl -> 2 + 2 * Array.length tbl (* blr/nop b/nop *)
-  | Lsetuptrap _ -> 2 (* bl/nop *)
-  | Lpushtrap -> 3 (* stws,ma/stw/copy *)
-  | Lpoptrap -> 1 (* ldws,mb *)
-  | Lraise -> 4 (* ldw/copy/bv/ldws,mb *)
-
-(* Estimate the position of all labels in function body
-   and rewrite long conditional branches with a negative label. *)
-
-let fixup_cond_branches funbody =
-  let label_position =
-    (Hashtbl.create 87 : (label, int) Hashtbl.t) in
-  let rec estimate_labels pos i =
-    match i.desc with
-      Lend -> ()
-    | Llabel lbl ->
-        Hashtbl.add label_position lbl pos; estimate_labels pos i.next
-    | _ -> estimate_labels (pos + sizeof_instr i) i.next in
-  let long_branch currpos lbl =
-    try
-      let displ = Hashtbl.find label_position lbl - currpos in
-      (* Branch offset is stored in 12 bits, giving a range of
-         -2048 to +2047. Here, we allow 10% error in estimating
-         the code positions. *)
-      displ < -1843 || displ > 1842
-    with Not_found ->
-      assert false in
-  let rec fix_branches pos i =
-    match i.desc with
-      Lend -> ()
-    | Lcondbranch(tst, lbl) ->
-        if long_branch pos lbl then i.desc <- Lcondbranch(tst, -lbl);
-        fix_branches (pos + sizeof_instr i) i.next
-    | Lcondbranch3(opt1, opt2, opt3) ->
-        let fix_opt = function
-          None -> None
-        | Some lbl -> Some(if long_branch pos lbl then -lbl else lbl) in
-        i.desc <- Lcondbranch3(fix_opt opt1, fix_opt opt2, fix_opt opt3);
-        fix_branches (pos + sizeof_instr i) i.next
-    | _ ->
-        fix_branches (pos + sizeof_instr i) i.next in
-  estimate_labels 0 funbody;
-  fix_branches 0 funbody
-
-(* Emission of a function declaration *)
-
-let fundecl fundecl =
-  fixup_cond_branches fundecl.fun_body;
-  function_name := fundecl.fun_name;
-  fastcode_flag := fundecl.fun_fast;
-  tailrec_entry_point := new_label();
-  stack_offset := 0;
-  float_constants := [];
-  define_symbol fundecl.fun_name;
-  range_check_trap := 0;
-  let n = frame_size() in
-  begin match Config.system with
-  | "hpux" ->
-    `  .code\n`;
-    `  .align  4\n`;
-    `  .export {emit_symbol fundecl.fun_name}, entry, priv_lev=3\n`;
-    `{emit_symbol fundecl.fun_name}:\n`;
-    `  .proc\n`;
-    if !contains_calls then
-      `        .callinfo frame={emit_int n}, calls, save_rp\n`
-    else
-      `        .callinfo frame={emit_int n}, no_calls\n`;
-    `  .entry\n`
-  | "linux" | "gnu" ->
-    `  .text\n`;
-    `  .align  8\n`;
-    `  .globl  {emit_symbol fundecl.fun_name}\n`;
-    `{emit_symbol fundecl.fun_name}:\n`
-  | _ ->
-    assert false
-  end;
-  if !contains_calls then
-    `  stwm    %r2, {emit_int n}(%r30)\n`
-  else if n > 0 then
-    `  ldo     {emit_int n}(%r30), %r30\n`;
-  `{emit_label !tailrec_entry_point}:\n`;
-  emit_all fundecl.fun_body;
-  if !range_check_trap > 0 then begin
-    `{emit_label !range_check_trap}:\n`;
-    emit_call "caml_ml_array_bound_error" "%r31";
-    `  nop\n`
-  end;
-  if Config.system = "hpux"then begin
-    `  .exit\n`;
-    `  .procend\n`
-  end;
-  emit_float_constants()
-
-(* Emission of data *)
-
-let declare_global s =
-  define_symbol s;
-  if Config.system = "hpux"
-  then `       .export {emit_symbol s}, data\n`
-  else `       .globl  {emit_symbol s}\n`
-
-let emit_item = function
-    Cglobal_symbol s ->
-      declare_global s
-  | Cdefine_symbol s ->
-      define_symbol s;
-      `{emit_symbol s}:\n`
-  | Cdefine_label lbl ->
-      `{emit_label (lbl + 100000)}:\n`
-  | Cint8 n ->
-      `        .byte   {emit_int n}\n`
-  | Cint16 n ->
-      `        .short  {emit_int n}\n`
-  | Cint32 n ->
-      `        .long   {emit_nativeint n}\n`
-  | Cint n ->
-      `        .long   {emit_nativeint n}\n`
-  | Csingle f ->
-      emit_float32_directive ".long" f
-  | Cdouble f ->
-      emit_float64_split_directive ".long" f
-  | Csymbol_address s ->
-      use_symbol s;
-      `        .long   {emit_symbol s}\n`
-  | Clabel_address lbl ->
-      `        .long   {emit_label(lbl + 100000)}\n`
-  | Cstring s ->
-      emit_string_directive "  .ascii  " s
-  | Cskip n ->
-      if n > 0 then
-        if Config.system = "hpux"
-        then ` .block  {emit_int n}\n`
-        else ` .space  {emit_int n}\n`
-  | Calign n ->
-      emit_align n
-
-let data l =
-  `    .data\n`;
-  List.iter emit_item l
-
-(* Beginning / end of an assembly file *)
-
-let begin_assembly() =
-  if Config.system = "hpux" then begin
-    `  .space $PRIVATE$\n`;
-    `  .subspa $DATA$,quad=1,align=8,access=31\n`;
-    `  .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82\n`;
-    `  .space $TEXT$\n`;
-    `  .subspa $LIT$,quad=0,align=8,access=44\n`;
-    `  .subspa $CODE$,quad=0,align=8,access=44,code_only\n`;
-    `  .import $global$, data\n`;
-    `  .import $$divI, millicode\n`;
-    `  .import $$remI, millicode\n`
-  end;
-  used_symbols := StringSet.empty;
-  defined_symbols := StringSet.empty;
-  called_symbols := StringSet.empty;
-  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
-  `    .data\n`;
-  declare_global lbl_begin;
-  `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
-  `    .code\n`;
-  declare_global lbl_begin;
-  `{emit_symbol lbl_begin}:\n`
-
-
-let end_assembly() =
-  `    .code\n`;
-  let lbl_end = Compilenv.make_symbol (Some "code_end") in
-  declare_global lbl_end;
-  `{emit_symbol lbl_end}:\n`;
-  `    .data\n`;
-  let lbl_end = Compilenv.make_symbol (Some "data_end") in
-  declare_global lbl_end;
-  `{emit_symbol lbl_end}:\n`;
-  `    .long   0\n`;
-  let lbl = Compilenv.make_symbol (Some "frametable") in
-  declare_global lbl;
-  `{emit_symbol lbl}:\n`;
-  `    .long   {emit_int (List.length !frame_descriptors)}\n`;
-  List.iter emit_frame !frame_descriptors;
-  frame_descriptors := [];
-  emit_imports()

diff --git a/asmcomp/hppa/proc.ml b/asmcomp/hppa/proc.ml
deleted file mode 100644 (file)
index c0b40ad..0000000
--- a/asmcomp/hppa/proc.ml
+++ /dev/null
@@ -1,224 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Description of the HP PA-RISC processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Mach
-
-(* Registers available for register allocation *)
-
-(* Register map:
-    %r0                         always zero
-    %r1                         temporary, target of ADDIL
-    %r2                         return address
-    %r3                         allocation pointer
-    %r4                         allocation limit
-    %r5                         trap pointer
-    %r6 - %r26                  general purpose
-    %r27                        global pointer
-    %r28 - %r29                 general purpose, C function results
-    %r30                        stack pointer
-    %r31                        temporary, used by BLE
-
-    %fr0 - %fr3                 float status info
-    %fr4 - %fr30                general purpose
-    %fr31                       temporary *)
-
-let int_reg_name = [|
-  (* 0-4 *)   "%r6"; "%r7"; "%r8"; "%r9"; "%r10";
-  (* 5-10 *)  "%r11"; "%r12"; "%r13"; "%r14"; "%r15"; "%r16";
-  (* 11-16 *) "%r17"; "%r18"; "%r19"; "%r20"; "%r21"; "%r22";
-  (* 17-20 *) "%r23"; "%r24"; "%r25"; "%r26";
-  (* 21-22 *) "%r28"; "%r29"
-|]
-
-let float_reg_name = [|
-  (* 100-105 *) "%fr4"; "%fr5"; "%fr6"; "%fr7"; "%fr8"; "%fr9";
-  (* 106-111 *) "%fr10"; "%fr11"; "%fr12"; "%fr13"; "%fr14"; "%fr15";
-  (* 112-117 *) "%fr16"; "%fr17"; "%fr18"; "%fr19"; "%fr20"; "%fr21";
-  (* 118-123 *) "%fr22"; "%fr23"; "%fr24"; "%fr25"; "%fr26"; "%fr27";
-  (* 124-127 *) "%fr28"; "%fr29"; "%fr30"; "%fr31"
-|]
-
-let num_register_classes = 2
-
-let register_class r =
-  match r.typ with
-    Int -> 0
-  | Addr -> 0
-  | Float -> 1
-
-let num_available_registers = [| 23; 27 |]
-
-let first_available_register = [| 0; 100 |]
-
-let register_name r =
-  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
-
-let rotate_registers = true
-
-(* Representation of hard registers by pseudo-registers *)
-
-let hard_int_reg =
-  let v = Array.create 23 Reg.dummy in
-  for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done;
-  v
-
-let hard_float_reg =
-  let v = Array.create 28 Reg.dummy in
-  for i = 0 to 27 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done;
-  v
-
-let all_phys_regs =
-  Array.append hard_int_reg (Array.sub hard_float_reg 0 27)
-  (* No need to include the left/right parts of float registers *)
-
-let phys_reg n =
-  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
-
-let stack_slot slot ty =
-  Reg.at_location ty (Stack slot)
-
-(* Instruction selection *)
-
-let word_addressed = false
-
-(* Calling conventions *)
-
-let calling_conventions first_int last_int first_float last_float make_stack
-                        arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let int = ref first_int in
-  let float = ref first_float in
-  let ofs = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-      Int | Addr as ty ->
-        if !int >= last_int then begin
-          loc.(i) <- phys_reg !int;
-          decr int
-        end else begin
-          ofs := !ofs + size_int;
-          loc.(i) <- stack_slot (make_stack !ofs) ty
-        end
-    | Float ->
-        if !float <= last_float then begin
-          loc.(i) <- phys_reg !float;
-          incr float
-        end else begin
-          ofs := Misc.align (!ofs + size_float) 8;
-          loc.(i) <- stack_slot (make_stack !ofs) Float
-        end
-  done;
-  (loc, Misc.align !ofs 8)         (* Keep stack 8-aligned *)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
-
-(* Arguments and results: %r26-%r19, %fr4-%fr11. *)
-
-let loc_arguments arg =
-  calling_conventions 20 13 100 107 outgoing arg
-let loc_parameters arg =
-  let (loc, ofs) = calling_conventions  20 13 100 107 incoming arg in loc
-let loc_results res =
-  let (loc, ofs) = calling_conventions  20 13 100 107 not_supported res in loc
-
-(* Calling C functions:
-    when all arguments are integers, use %r26 - %r23,
-    then -52(%r30), -56(%r30), etc.
-    When some arguments are floats, we handle a couple of cases by hand
-    and fail otherwise. *)
-
-let loc_external_arguments arg =
-  match List.map register_class (Array.to_list arg) with
-    [1] -> ([| phys_reg 101 |], 56)           (* %fr5 *)
-  | [1; 1] -> ([| phys_reg 101; phys_reg 103 |], 56) (* %fr5, %fr7 *)
-  | [1; 0] -> ([| phys_reg 101; phys_reg 18 |], 56) (* %fr5, %r24 *)
-  | [0; 1] -> ([| phys_reg 20; phys_reg 103 |], 56) (* %r26, %fr7 *)
-  | _ ->
-    let loc = Array.create (Array.length arg) Reg.dummy in
-    let int = ref 20 in
-    let ofs = ref 48 in
-    for i = 0 to Array.length arg - 1 do
-      match arg.(i).typ with
-        Int | Addr as ty ->
-          if !int >= 17 then begin
-            loc.(i) <- phys_reg (!int);
-            decr int
-          end else begin
-            ofs := !ofs + 4;
-            loc.(i) <- stack_slot (Outgoing !ofs) ty
-          end
-      | Float ->
-          fatal_error "Proc.external_calling_conventions: cannot call"
-    done;
-    (loc, Misc.align !ofs 8)
-
-let loc_external_results res =
-  let (loc, ofs) = calling_conventions 21 21 100 100 not_supported res in loc
-
-let loc_exn_bucket = phys_reg 20        (* %r26 *)
-
-(* Registers destroyed by operations *)
-
-let destroyed_at_c_call = (* %r3 - %r18, %fr12 - %fr21 preserved *)
-  Array.of_list(List.map phys_reg
-    [13;14;15;16;17;18;19;20;21;22;
-     100;101;102;103;104;105;106;107;118;119;120;121;122;123;124;125;126])
-
-let destroyed_by_millicode = (* %r25, %r26, %r28, %r29 -- more? *)
-  [| phys_reg 19; phys_reg 20; phys_reg 21; phys_reg 22 |]
-
-let destroyed_by_alloc = [| phys_reg 22 |] (* %r29 *)
-
-let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
-  | Iop(Iintop(Idiv | Imod)) -> destroyed_by_millicode
-  | Iop(Ialloc _) -> destroyed_by_alloc
-  | _ -> [||]
-
-let destroyed_at_raise = all_phys_regs
-
-(* Maximal register pressure *)
-
-let safe_register_pressure = function
-    Iextcall(_, _) -> 16
-  | Iintop(Idiv | Imod) -> 19
-  | _ -> 23
-
-let max_register_pressure = function
-    Iextcall(_, _) -> [| 16; 19 |]
-  | Iintop(Idiv | Imod) -> [| 19; 27 |]
-  | _ -> [| 23; 27 |]
-
-(* Layout of the stack *)
-
-let num_stack_slots = [| 0; 0 |]
-let contains_calls = ref false
-
-(* Calling the assembler *)
-
-let assemble_file infile outfile =
-  Ccomp.command (Config.asm ^ " -o " ^
-                 Filename.quote outfile ^ " " ^ Filename.quote infile)
-
-open Clflags;;
-open Config;;

diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml
deleted file mode 100644 (file)
index 54208fc..0000000
--- a/asmcomp/hppa/reload.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Reloading for the HPPA *)
-
-
-open Cmm
-open Arch
-open Reg
-open Mach
-open Proc
-
-class reload = object (self)
-
-inherit Reloadgen.reload_generic as super
-
-method reload_operation op arg res =
-  match op with
-      Iintop(Idiv | Imod)
-    | Iintop_imm((Idiv | Imod), _)  -> (arg, res)
-    | _ -> super#reload_operation op arg res
-end
-
-
-
-let fundecl f =
-  (new reload)#fundecl f

diff --git a/asmcomp/hppa/scheduling.ml b/asmcomp/hppa/scheduling.ml
deleted file mode 100644 (file)
index 0cdd099..0000000
--- a/asmcomp/hppa/scheduling.ml
+++ /dev/null
@@ -1,59 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Instruction scheduling for the HPPA *)
-
-open Arch
-open Mach
-
-class scheduler = object (self)
-
-inherit Schedgen.scheduler_generic
-
-(* Latencies (in cycles). Roughly based on the ``Mustang'' chips. *)
-
-method oper_latency = function
-    Ireload -> 2
-  | Iload(_, _) -> 2
-  | Iconst_float _ -> 2                 (* turned into a load *)
-  | Iintop Imul -> 2                    (* ends up with a load *)
-  | Iaddf | Isubf | Imulf -> 3
-  | Idivf -> 12
-  | _ -> 1
-
-(* Issue cycles.  Rough approximations. *)
-
-method oper_issue_cycles = function
-    Iconst_float _ -> 3
-  | Iconst_symbol _ -> 2
-  | Iload(_, Ibased(_, _)) -> 2
-  | Istore(_, Ibased(_, _)) -> 2
-  | Ialloc _ -> 5
-  | Iintop Imul -> 10
-  | Iintop Ilsl -> 3
-  | Iintop Ilsr -> 2
-  | Iintop Iasr -> 3
-  | Iintop(Icomp _) -> 2
-  | Iintop(Icheckbound) -> 2
-  | Iintop_imm(Idiv, _) -> 4
-  | Iintop_imm(Imod, _) -> 5
-  | Iintop_imm(Icomp _, _) -> 2
-  | Iintop_imm(Icheckbound, _) -> 2
-  | Ifloatofint -> 4
-  | Iintoffloat -> 4
-  | _ -> 1
-
-end
-
-let fundecl f = (new scheduler)#schedule_fundecl f

diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml
deleted file mode 100644 (file)
index 74c546b..0000000
--- a/asmcomp/hppa/selection.ml
+++ /dev/null
@@ -1,109 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Instruction selection for the HPPA processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Proc
-open Mach
-
-let shiftadd = function
-    2 -> Ishift1add
-  | 4 -> Ishift2add
-  | 8 -> Ishift3add
-  | _ -> fatal_error "Proc_hppa.shiftadd"
-
-class selector = object (self)
-
-inherit Selectgen.selector_generic as super
-
-method is_immediate n = (n < 16) && (n >= -16) (* 5 bits *)
-
-method select_addressing = function
-    Cconst_symbol s ->
-      (Ibased(s, 0), Ctuple [])
-  | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
-      (Ibased(s, n), Ctuple [])
-  | Cop(Cadda, [arg; Cconst_int n]) ->
-      (Iindexed n, arg)
-  | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
-      (Iindexed n, Cop(Cadda, [arg1; arg2]))
-  | arg ->
-      (Iindexed 0, arg)
-
-method! select_operation op args =
-  match (op, args) with
-  (* Recognize shift-add operations. *)
-    ((Caddi|Cadda),
-     [arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)])]) ->
-      (Ispecific(shiftadd(1 lsl shift)), [arg1; arg2])
-  | ((Caddi|Cadda),
-     [arg2; Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)])]) ->
-      (Ispecific(shiftadd mult), [arg1; arg2])
-  | ((Caddi|Cadda),
-     [arg2; Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1])]) ->
-      (Ispecific(shiftadd mult), [arg1; arg2])
-  | (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3 as shift)]); arg2]) ->
-      (Ispecific(shiftadd(1 lsl shift)), [arg1; arg2])
-  | (Caddi, [Cop(Cmuli, [arg1; Cconst_int(2|4|8 as mult)]); arg2]) ->
-      (Ispecific(shiftadd mult), [arg1; arg2])
-  | (Caddi, [Cop(Cmuli, [Cconst_int(2|4|8 as mult); arg1]); arg2]) ->
-      (Ispecific(shiftadd mult), [arg1; arg2])
-  (* Prevent the recognition of some immediate arithmetic operations *)
-  (* Cmuli : -> Ilsl if power of 2
-     Cdivi, Cmodi : only if power of 2
-     Cand, Cor, Cxor : never *)
-  | (Cmuli, ([arg1; Cconst_int n] as args)) ->
-      let l = Misc.log2 n in
-      if n = 1 lsl l
-      then (Iintop_imm(Ilsl, l), [arg1])
-      else (Iintop Imul, args)
-  | (Cmuli, ([Cconst_int n; arg1] as args)) ->
-      let l = Misc.log2 n in
-      if n = 1 lsl l
-      then (Iintop_imm(Ilsl, l), [arg1])
-      else (Iintop Imul, args)
-  | (Cmuli, args) -> (Iintop Imul, args)
-  | (Cdivi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
-      (Iintop_imm(Idiv, n), [arg1])
-  | (Cdivi, args) -> (Iintop Idiv, args)
-  | (Cmodi, [arg1; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
-      (Iintop_imm(Imod, n), [arg1])
-  | (Cmodi, args) -> (Iintop Imod, args)
-  | (Cand, args) -> (Iintop Iand, args)
-  | (Cor, args) -> (Iintop Ior, args)
-  | (Cxor, args) -> (Iintop Ixor, args)
-  | _ ->
-      super#select_operation op args
-
-(* Deal with register constraints *)
-
-method! insert_op_debug op dbg rs rd =
-  match op with
-    Iintop(Idiv | Imod) -> (* handled via calls to millicode *)
-      let rs' = [|phys_reg 20; phys_reg 19|] (* %r26, %r25 *)
-      and rd' = [|phys_reg 22|] (* %r29 *) in
-      self#insert_moves rs rs';
-      self#insert_debug (Iop op) dbg rs' rd';
-      self#insert_moves rd' rd;
-      rd
-  | _ ->
-      super#insert_op_debug op dbg rs rd
-
-end
-
-let fundecl f = (new selector)#emit_fundecl f

diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml
index 04d673d91d709db9735f7339e5f886584c85b5eb..e6fb8b9008dd94bbe054b4092c4bdc6c61f26d2d 100644 (file)
--- a/asmcomp/i386/arch.ml
+++ b/asmcomp/i386/arch.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -59,6 +59,10 @@ let size_addr = 4
 let size_int = 4
 let size_float = 8
 
+(* Behavior of division *)
+
+let division_crashes_on_overflow = true
+
 (* Operations on addressing modes *)
 
 let identity_addressing = Iindexed 0

diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index 881a936a14ecefdfddee96a7586befd70047b90b..d52b1db6708c00e2c03414978eeda9f0b418e7d4 100644 (file)
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -82,6 +82,9 @@ let label_prefix =
 let emit_label lbl =
   emit_string label_prefix; emit_int lbl
 
+let emit_data_label lbl =
+  emit_string label_prefix; emit_string "d"; emit_int lbl
+
 
 (* Some data directives have different names under Solaris *)
 
@@ -309,9 +312,18 @@ let output_test_zero arg =
 
 (* Deallocate the stack frame before a return or tail call *)
 
-let output_epilogue () =
+let output_epilogue f =
   let n = frame_size() - 4 in
-  if n > 0 then `      addl    ${emit_int n}, %esp\n`
+  if n > 0 then
+  begin
+    `  addl    ${emit_int n}, %esp\n`;
+    cfi_adjust_cfa_offset (-n);
+    f ();
+    (* reset CFA back cause function body may continue *)
+    cfi_adjust_cfa_offset n
+  end
+  else
+    f ()
 
 (* Determine if the given register is the top of the floating-point stack *)
 
@@ -415,6 +427,7 @@ let external_symbols_direct = ref StringSet.empty
 let external_symbols_indirect = ref StringSet.empty
 
 let emit_instr fallthrough i =
+    emit_debug_info i.dbg;
     match i.desc with
       Lend -> ()
     | Lop(Imove | Ispill | Ireload) ->
@@ -463,14 +476,16 @@ let emit_instr fallthrough i =
         `      call    {emit_symbol s}\n`;
         record_frame i.live i.dbg
     | Lop(Itailcall_ind) ->
-        output_epilogue();
+        output_epilogue begin fun () ->
         `      jmp     *{emit_reg i.arg.(0)}\n`
+        end
     | Lop(Itailcall_imm s) ->
         if s = !function_name then
           `    jmp     {emit_label !tailrec_entry_point}\n`
         else begin
-          output_epilogue();
+          output_epilogue begin fun () ->
           `    jmp     {emit_symbol s}\n`
+          end
         end
     | Lop(Iextcall(s, alloc)) ->
         if alloc then begin
@@ -496,6 +511,7 @@ let emit_instr fallthrough i =
         if n < 0
         then ` addl    ${emit_int(-n)}, %esp\n`
         else ` subl    ${emit_int(n)}, %esp\n`;
+        cfi_adjust_cfa_offset n;
         stack_offset := !stack_offset + n
     | Lop(Iload(chunk, addr)) ->
         let dest = i.res.(0) in
@@ -649,6 +665,7 @@ let emit_instr fallthrough i =
           `    fldl    {emit_reg i.arg.(0)}\n`;
         stack_offset := !stack_offset - 8;
         `      subl    $8, %esp\n`;
+        cfi_adjust_cfa_offset 8;
         `      fnstcw  4(%esp)\n`;
         `      movw    4(%esp), %ax\n`;
         `      movb    $12, %ah\n`;
@@ -663,6 +680,7 @@ let emit_instr fallthrough i =
         end;
         `      fldcw   4(%esp)\n`;
         `      addl    $8, %esp\n`;
+        cfi_adjust_cfa_offset (-8);
         stack_offset := !stack_offset + 8
     | Lop(Ispecific(Ilea addr)) ->
         `      lea     {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n`
@@ -679,29 +697,36 @@ let emit_instr fallthrough i =
           match r with
             {loc = Reg _; typ = Float} ->
               `        subl    $8, %esp\n`;
+              cfi_adjust_cfa_offset 8;
               `        fstpl   0(%esp)\n`;
               stack_offset := !stack_offset + 8
           | {loc = Stack sl; typ = Float} ->
               let ofs = slot_offset sl 1 in
               `        pushl   {emit_int(ofs + 4)}(%esp)\n`;
               `        pushl   {emit_int(ofs + 4)}(%esp)\n`;
+              cfi_adjust_cfa_offset 8;
               stack_offset := !stack_offset + 8
           | _ ->
               `        pushl   {emit_reg r}\n`;
+              cfi_adjust_cfa_offset 4;
               stack_offset := !stack_offset + 4
         done
     | Lop(Ispecific(Ipush_int n)) ->
         `      pushl   ${emit_nativeint n}\n`;
+        cfi_adjust_cfa_offset 4;
         stack_offset := !stack_offset + 4
     | Lop(Ispecific(Ipush_symbol s)) ->
         `      pushl   ${emit_symbol s}\n`;
+        cfi_adjust_cfa_offset 4;
         stack_offset := !stack_offset + 4
     | Lop(Ispecific(Ipush_load addr)) ->
         `      pushl   {emit_addressing addr i.arg 0}\n`;
+        cfi_adjust_cfa_offset 4;
         stack_offset := !stack_offset + 4
     | Lop(Ispecific(Ipush_load_float addr)) ->
         `      pushl   {emit_addressing (offset_addressing addr 4) i.arg 0}\n`;
         `      pushl   {emit_addressing addr i.arg 0}\n`;
+        cfi_adjust_cfa_offset 8;
         stack_offset := !stack_offset + 8
     | Lop(Ispecific(Ifloatarithmem(double, op, addr))) ->
         if not (is_tos i.arg.(0)) then
@@ -719,8 +744,9 @@ let emit_instr fallthrough i =
     | Lreloadretaddr ->
         ()
     | Lreturn ->
-        output_epilogue();
+        output_epilogue begin fun () ->
         `      ret\n`
+        end
     | Llabel lbl ->
         `{emit_Llabel fallthrough lbl}:\n`
     | Lbranch lbl ->
@@ -784,11 +810,13 @@ let emit_instr fallthrough i =
         if trap_frame_size > 8 then
           `    subl    ${emit_int (trap_frame_size - 8)}, %esp\n`;
         `      pushl   {emit_symbol "caml_exception_pointer"}\n`;
+        cfi_adjust_cfa_offset trap_frame_size;
         `      movl    %esp, {emit_symbol "caml_exception_pointer"}\n`;
         stack_offset := !stack_offset + trap_frame_size
     | Lpoptrap ->
         `      popl    {emit_symbol "caml_exception_pointer"}\n`;
         `      addl    ${emit_int (trap_frame_size - 4)}, %esp\n`;
+        cfi_adjust_cfa_offset (-trap_frame_size);
         stack_offset := !stack_offset - trap_frame_size
     | Lraise ->
         if !Clflags.debug then begin
@@ -897,14 +925,20 @@ let fundecl fundecl =
   else
     `  .globl  {emit_symbol fundecl.fun_name}\n`;
   `{emit_symbol fundecl.fun_name}:\n`;
+  emit_debug_info fundecl.fun_dbg;
+  cfi_startproc ();
   if !Clflags.gprofile then emit_profile();
   let n = frame_size() - 4 in
   if n > 0 then
+  begin
     `  subl    ${emit_int n}, %esp\n`;
+    cfi_adjust_cfa_offset n;
+  end;
   `{emit_label !tailrec_entry_point}:\n`;
   emit_all true fundecl.fun_body;
   List.iter emit_call_gc !call_gc_sites;
   emit_call_bound_errors ();
+  cfi_endproc ();
   begin match Config.system with
     "linux_elf" | "bsd_elf" | "gnu" ->
       `        .type   {emit_symbol fundecl.fun_name},@function\n`;
@@ -921,7 +955,7 @@ let emit_item = function
   | Cdefine_symbol s ->
       `{emit_symbol s}:\n`
   | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)}:\n`
+      `{emit_data_label lbl}:\n`
   | Cint8 n ->
       `        .byte   {emit_int n}\n`
   | Cint16 n ->
@@ -937,7 +971,7 @@ let emit_item = function
   | Csymbol_address s ->
       `        .long   {emit_symbol s}\n`
   | Clabel_address lbl ->
-      `        .long   {emit_label (100000 + lbl)}\n`
+      `        .long   {emit_data_label lbl}\n`
   | Cstring s ->
       if use_ascii_dir
       then emit_string_directive "     .ascii  " s

diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp
index 7091b3df8fe43fc6ddee1114c02fc896291da050..48704ab4013b418e61b712467354ea19fcf3f504 100644 (file)
--- a/asmcomp/i386/emit_nt.mlp
+++ b/asmcomp/i386/emit_nt.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -71,6 +71,9 @@ let emit_int32 n = emit_printf "0%lxh" n
 let emit_label lbl =
   emit_string "L"; emit_int lbl
 
+let emit_data_label lbl =
+  emit_string "Ld"; emit_int lbl
+
 (* Output an align directive. *)
 
 let emit_align n = `   ALIGN   {emit_int n}\n`
@@ -813,7 +816,7 @@ let emit_item = function
       add_def_symbol s ;
       `{emit_symbol s} LABEL DWORD\n`
   | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)}     LABEL DWORD\n`
+      `{emit_data_label lbl}   LABEL DWORD\n`
   | Cint8 n ->
       `        BYTE    {emit_int n}\n`
   | Cint16 n ->
@@ -830,7 +833,7 @@ let emit_item = function
       add_used_symbol s ;
       `        DWORD   {emit_symbol s}\n`
   | Clabel_address lbl ->
-      `        DWORD   {emit_label (100000 + lbl)}\n`
+      `        DWORD   {emit_data_label lbl}\n`
   | Cstring s ->
       emit_bytes_directive "   BYTE    " s
   | Cskip n ->
@@ -881,6 +884,7 @@ let end_assembly() =
   add_def_symbol lbl_end;
   `    PUBLIC  {emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}       LABEL   DWORD\n`;
+  `    DWORD   0\n`;
   let lbl = Compilenv.make_symbol (Some "frametable") in
   add_def_symbol lbl;
   `    PUBLIC  {emit_symbol lbl}\n`;

diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml
index d2e3cdda9676c1df48d76e68647d8c22c5de8e52..10ac59bfced13ce3402e4bffda58eac2008f7ef5 100644 (file)
--- a/asmcomp/i386/proc.ml
+++ b/asmcomp/i386/proc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,6 +20,12 @@ open Cmm
 open Reg
 open Mach
 
+(* Which asm conventions to use *)
+let masm =
+  match Config.ccomp_type with
+  | "msvc" -> true
+  | _      -> false
+
 (* Registers available for register allocation *)
 
 (* Register map:
@@ -34,10 +40,16 @@ open Mach
     tos         100             top of floating-point stack. *)
 
 let int_reg_name =
-  [| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |]
+  if masm then
+    [| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |]
+  else
+    [| "%eax"; "%ebx"; "%ecx"; "%edx"; "%esi"; "%edi"; "%ebp" |]
 
 let float_reg_name =
-  [| "%tos" |]
+  if masm then
+    [| "tos" |]
+  else
+    [| "%tos" |]
 
 let num_register_classes = 2
 
@@ -181,8 +193,13 @@ let contains_calls = ref false
 (* Calling the assembler *)
 
 let assemble_file infile outfile =
-  Ccomp.command (Config.asm ^ " -o " ^
-                 Filename.quote outfile ^ " " ^ Filename.quote infile)
+  if masm then
+    Ccomp.command (Config.asm ^
+                   Filename.quote outfile ^ " " ^ Filename.quote infile ^
+                   (if !Clflags.verbose then "" else ">NUL"))
+  else
+    Ccomp.command (Config.asm ^ " -o " ^
+                   Filename.quote outfile ^ " " ^ Filename.quote infile)
 
 open Clflags;;
 open Config;;

diff --git a/asmcomp/i386/proc_nt.ml b/asmcomp/i386/proc_nt.ml
deleted file mode 100644 (file)
index 5e617ff..0000000
--- a/asmcomp/i386/proc_nt.ml
+++ /dev/null
@@ -1,186 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Description of the Intel 386 processor, for Windows NT *)
-
-open Misc
-open Arch
-open Cmm
-open Reg
-open Mach
-
-(* Registers available for register allocation *)
-
-(* Register map:
-    eax         0               eax - edi: function arguments and results
-    ebx         1               eax: C function results
-    ecx         2               ebx, esi, edi, ebp: preserved by C
-    edx         3
-    esi         4
-    edi         5
-    ebp         6
-
-    tos         100             top of floating-point stack. *)
-
-let int_reg_name =
-  [| "eax"; "ebx"; "ecx"; "edx"; "esi"; "edi"; "ebp" |]
-
-let float_reg_name =
-  [| "tos" |]
-
-let num_register_classes = 2
-
-let register_class r =
-  match r.typ with
-    Int -> 0
-  | Addr -> 0
-  | Float -> 1
-
-let num_available_registers = [| 7; 0 |]
-
-let first_available_register = [| 0; 100 |]
-
-let register_name r =
-  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
-
-(* There is little scheduling, and some operations are more compact
-   when their argument is %eax. *)
-
-let rotate_registers = false
-
-(* Representation of hard registers by pseudo-registers *)
-
-let hard_int_reg =
-  let v = Array.create 7 Reg.dummy in
-  for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done;
-  v
-
-let hard_float_reg = [| Reg.at_location Float (Reg 100) |]
-
-let all_phys_regs =
-  Array.append hard_int_reg hard_float_reg
-
-let phys_reg n =
-  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
-
-let eax = phys_reg 0
-let ecx = phys_reg 2
-let edx = phys_reg 3
-let tos = phys_reg 100
-
-let stack_slot slot ty =
-  Reg.at_location ty (Stack slot)
-
-(* Instruction selection *)
-
-let word_addressed = false
-
-(* Calling conventions *)
-
-(* To supplement the processor's meagre supply of registers, we also
-   use some global memory locations to pass arguments beyond the 6th.
-   These globals are denoted by Incoming and Outgoing stack locations
-   with negative offsets, starting at -64.
-   Unlike arguments passed on stack, arguments passed in globals
-   do not prevent tail-call elimination.  The caller stores arguments
-   in these globals immediately before the call, and the first thing the
-   callee does is copy them to registers or stack locations.
-   Neither GC nor thread context switches can occur between these two
-   times. *)
-
-let calling_conventions first_int last_int first_float last_float make_stack
-                        arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let int = ref first_int in
-  let float = ref first_float in
-  let ofs = ref (-64) in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-      Int | Addr as ty ->
-        if !int <= last_int then begin
-          loc.(i) <- phys_reg !int;
-          incr int
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) ty;
-          ofs := !ofs + size_int
-        end
-    | Float ->
-        if !float <= last_float then begin
-          loc.(i) <- phys_reg !float;
-          incr float
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) Float;
-          ofs := !ofs + size_float
-        end
-  done;
-  (loc, max 0 !ofs)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
-
-let loc_arguments arg =
-  calling_conventions 0 5 100 99 outgoing arg
-let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 0 5 100 99 incoming arg in loc
-let loc_results res =
-  let (loc, ofs) = calling_conventions 0 5 100 100 not_supported res in loc
-let extcall_use_push = true
-let loc_external_arguments arg =
-  fatal_error "Proc.loc_external_arguments"
-let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
-
-let loc_exn_bucket = eax
-
-(* Registers destroyed by operations *)
-
-let destroyed_at_c_call =               (* ebx, esi, edi, ebp preserved *)
-  Array.of_list(List.map phys_reg [0;2;3])
-
-let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
-  | Iop(Iintop(Idiv | Imod)) -> [| eax; edx |]
-  | Iop(Iintop_imm(Imod, _)) -> [| eax |]
-  | Iop(Ialloc _) -> [| eax |]
-  | Iop(Iintop(Icomp _) | Iintop_imm(Icomp _, _)) -> [| eax |]
-  | Iop(Iintoffloat) -> [| eax |]
-  | Iifthenelse(Ifloattest(_, _), _, _) -> [| eax |]
-  | _ -> [||]
-
-let destroyed_at_raise = all_phys_regs
-
-(* Maximal register pressure *)
-
-let safe_register_pressure op = 4
-
-let max_register_pressure = function
-    Iextcall(_, _) -> [| 4; max_int |]
-  | Iintop(Idiv | Imod) -> [| 5; max_int |]
-  | Ialloc _ | Iintop(Icomp _) | Iintop_imm(Icomp _, _) |
-    Iintoffloat -> [| 6; max_int |]
-  | _ -> [|7; max_int |]
-
-(* Layout of the stack frame *)
-
-let num_stack_slots = [| 0; 0 |]
-let contains_calls = ref false
-
-(* Calling the assembler *)
-
-let assemble_file infile outfile =
-  Ccomp.command (Config.asm ^
-                 Filename.quote outfile ^ " " ^ Filename.quote infile ^
-                 (if !Clflags.verbose then "" else ">NUL"))

diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml
index 539d45daeaa7177473b6f94362ad319d1fe49023..66ad6a140752fddb3e109c2dcd6e02b0098ea2f0 100644 (file)
--- a/asmcomp/i386/reload.ml
+++ b/asmcomp/i386/reload.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/i386/scheduling.ml b/asmcomp/i386/scheduling.ml
index 6f018cc8704800c20cb564049d5514f742c96167..cbfaa2111073c501b6871c79bfd09bd245fc0ace 100644 (file)
--- a/asmcomp/i386/scheduling.ml
+++ b/asmcomp/i386/scheduling.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml
index 5a8720fbeb10ab488d53ec6d1cf446870b97e0fc..38c7a1d73049d0219454666bb0a79a1f85e0ffc9 100644 (file)
--- a/asmcomp/i386/selection.ml
+++ b/asmcomp/i386/selection.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -168,7 +168,7 @@ method! is_simple_expr e =
   | _ ->
       super#is_simple_expr e
 
-method select_addressing exp =
+method select_addressing chunk exp =
   match select_addr exp with
     (Asymbol s, d) ->
       (Ibased(s, d), Ctuple [])
@@ -200,7 +200,7 @@ method! select_operation op args =
   match op with
   (* Recognize the LEA instruction *)
     Caddi | Cadda | Csubi | Csuba ->
-      begin match self#select_addressing (Cop(op, args)) with
+      begin match self#select_addressing Word (Cop(op, args)) with
         (Iindexed d, _) -> super#select_operation op args
       | (Iindexed2 0, _) -> super#select_operation op args
       | (addr, arg) -> (Ispecific(Ilea addr), [arg])
@@ -233,7 +233,7 @@ method! select_operation op args =
       begin match args with
         [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])]
         when loc = loc' ->
-          let (addr, arg) = self#select_addressing loc in
+          let (addr, arg) = self#select_addressing Word loc in
           (Ispecific(Ioffset_loc(n, addr)), [arg])
       | _ ->
           super#select_operation op args
@@ -250,11 +250,11 @@ method! select_operation op args =
 method select_floatarith regular_op reversed_op mem_op mem_rev_op args =
   match args with
     [arg1; Cop(Cload chunk, [loc2])] ->
-      let (addr, arg2) = self#select_addressing loc2 in
+      let (addr, arg2) = self#select_addressing chunk loc2 in
       (Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)),
                  [arg1; arg2])
   | [Cop(Cload chunk, [loc1]); arg2] ->
-      let (addr, arg1) = self#select_addressing loc1 in
+      let (addr, arg1) = self#select_addressing chunk loc1 in
       (Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)),
                  [arg2; arg1])
   | [arg1; arg2] ->
@@ -282,9 +282,6 @@ method! insert_op_debug op dbg rs rd =
   with Use_default ->
     super#insert_op_debug op dbg rs rd
 
-method! insert_op op rs rd =
-  self#insert_op_debug op Debuginfo.none rs rd
-
 (* Selection of push instructions for external calls *)
 
 method select_push exp =
@@ -295,10 +292,10 @@ method select_push exp =
   | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple [])
   | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple [])
   | Cop(Cload Word, [loc]) ->
-      let (addr, arg) = self#select_addressing loc in
+      let (addr, arg) = self#select_addressing Word loc in
       (Ispecific(Ipush_load addr), arg)
   | Cop(Cload Double_u, [loc]) ->
-      let (addr, arg) = self#select_addressing loc in
+      let (addr, arg) = self#select_addressing Double_u loc in
       (Ispecific(Ipush_load_float addr), arg)
   | _ -> (Ispecific(Ipush), exp)
 

diff --git a/asmcomp/ia64/arch.ml b/asmcomp/ia64/arch.ml
deleted file mode 100644 (file)
index 77dddac..0000000
--- a/asmcomp/ia64/arch.ml
+++ /dev/null
@@ -1,88 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Specific operations for the IA64 processor *)
-
-open Misc
-open Format
-
-(* Machine-specific command-line options *)
-
-let command_line_options = []
-
-(* Addressing modes -- only one! (register with no displacement) *)
-
-type addressing_mode = Iindexed
-
-(* Specific operations *)
-
-type specific_operation =
-    Iadd1                               (* x + y + 1 or x + x + 1 *)
-  | Isub1                               (* x - y - 1 *)
-  | Ishladd of int                      (* x << N + y *)
-  | Isignextend of int                  (* truncate 64-bit int to 8N-bit int *)
-  | Imultaddf                           (* x *. y +. z *)
-  | Imultsubf                           (* x *. y -. z *)
-  | Isubmultf                           (* z -. x *. y *)
-  | Istoreincr of int                   (* store y at x; x <- x + N *)
-  | Iinitbarrier                        (* end of object initialization *)
-
-(* Sizes, endianness *)
-
-let big_endian = false
-
-let size_addr = 8
-let size_int = 8
-let size_float = 8
-
-(* Operations on addressing modes *)
-
-let identity_addressing = Iindexed
-
-let offset_addressing addr delta = assert false
-
-let num_args_addressing = function Iindexed -> 1
-
-(* Printing operations and addressing modes *)
-
-let print_addressing printreg addr ppf arg =
-  printreg ppf arg.(0)
-
-let print_specific_operation printreg op ppf arg =
-  match op with
-  | Iadd1 ->
-      if Array.length arg >= 2 then
-        fprintf ppf "%a + %a + 1 " printreg arg.(0) printreg arg.(1)
-      else
-        fprintf ppf "%a << 1 + 1 " printreg arg.(0)
-  | Isub1 ->
-      fprintf ppf "%a - %a - 1 " printreg arg.(0) printreg arg.(1)
-  | Ishladd n ->
-      fprintf ppf "%a << %d + %a" printreg arg.(0) n printreg arg.(1)
-  | Isignextend n ->
-      fprintf ppf "truncate%d %a" (n * 8) printreg arg.(0)
-  | Imultaddf ->
-      fprintf ppf "%a * %a + %a"
-              printreg arg.(0) printreg arg.(1) printreg arg.(2)
-  | Imultsubf ->
-      fprintf ppf "%a * %a - %a"
-              printreg arg.(0) printreg arg.(1) printreg arg.(2)
-  | Isubmultf ->
-      fprintf ppf "%a - %a * %a"
-              printreg arg.(2) printreg arg.(0) printreg arg.(1)
-  | Istoreincr n ->
-      fprintf ppf "[%a] := %a; %a += %d"
-              printreg arg.(0) printreg arg.(1) printreg arg.(0) n
-  | Iinitbarrier ->
-      fprintf ppf "initbarrier"

diff --git a/asmcomp/ia64/emit.mlp b/asmcomp/ia64/emit.mlp
deleted file mode 100644 (file)
index 3d8eeb9..0000000
--- a/asmcomp/ia64/emit.mlp
+++ /dev/null
@@ -1,1327 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Emission of IA64 assembly code *)
-
-open Location
-open Printf
-open Misc
-open Cmm
-open Arch
-open Proc
-open Reg
-open Mach
-open Linearize
-open Emitaux
-
-(************** Part 1: assembly-level scheduler *******************)
-
-(* Representation of resources accessed or produced by instructions *)
-
-type resource = string
-  (* A resource is either:
-     - a register name
-     - "stkN" for a stack location
-     - "heap" for the Caml heap
-     - "chkN" for the result of a checkbound instruction *)
-
-let is_memory_resource rsrc =
-  String.length rsrc >= 4 &&
-  begin match String.sub rsrc 0 3 with
-    "stk" -> true
-  | "hea" -> true
-  | "chk" -> true
-  | _     -> false
-  end
-
-let is_mutable_resource rsrc =
-  rsrc <> "r0" && rsrc <> "p0"
-
-(* Description of instructions *)
-
-type instruction_kind =
-    KA                     (* A type instruction (int or mem unit) *)
-  | KB                     (* B type instruction (branch unit) *)
-  | KI                     (* I type instruction (int unit *)
-  | KF                     (* F type instruction (FP unit) *)
-  | KM                     (* M type instruction (mem unit) *)
-  | KB_exc                 (* B type instruction, exceptional condition,
-                              can be moved around *)
-
-type instruction_format =
-    F_i                                 (* op imm *)
-  | F_i_pred                            (* (pred) op imm *)
-  | F_ir_rr                             (* op p1,p2 = imm, r *)
-  | F_ir_r                              (* op r = imm, r *)
-  | F_ir_r_pred                         (* (pred) op r = imm, r *)
-  | F_ld                                (* op r = [r] *)
-  | F_ld_post                           (* op r = [r], imm *)
-  | F_r                                 (* op r *)
-  | F_i_r                               (* op r = imm *)
-  | F_i_r_pred                          (* (pred) op r = imm *)
-  | F_ri_rr                             (* op p1,p2 = imm, r *)
-  | F_ri_r                              (* op r = imm, r *)
-  | F_r_r                               (* op r = r *)
-  | F_r_r_pred                          (* (pred) op r = r *)
-  | F_rr_rr                             (* op p1,p2 = r1, r2 *)
-  | F_r_rir                             (* op r = r1, imm, r2 *)
-  | F_rr_r                              (* op r = r1, r2 *)
-  | F_rr_r_pred                         (* (pred) op r = r1, r2 *)
-  | F_rri_r                             (* op r = r1, r2, imm *)
-  | F_rrr_r                             (* op r = r1, r2, r3 *)
-  | F_rrr_r_pred                        (* (pred) op r = r1, r2, r3 *)
-  | F_st                                (* op [r] = r *)
-  | F_st_post                           (* op [r] = r, imm *)
-
-type instruction_descr =
-  { opcode: string;                (* actual opcode *)
-    latency: int;                  (* latency in cycles *)
-    kind: instruction_kind;        (* kind of instruction *)
-    format: instruction_format }   (* how to generate asm for it *)
-
-let instruction_table = create_hashtable 73 [
-  "add", {opcode = "add"; latency = 1; kind = KA; format = F_rr_r};
-  "add1", {opcode = "add"; latency = 1; kind = KA; format = F_rri_r};
-  "addcond", {opcode = "add"; latency = 1; kind = KA; format = F_rr_r_pred};
-  "addi", {opcode = "add"; latency = 1; kind = KA; format = F_ir_r};
-  "addicond", {opcode = "add"; latency = 1; kind = KA; format = F_ir_r_pred};
-  "and", {opcode = "and"; latency = 1; kind = KA; format = F_rr_r};
-  "andi", {opcode = "and"; latency = 1; kind = KA; format = F_ir_r};
-  "br", {opcode = "br.sptk.many"; latency = 1; kind = KB; format = F_i};
-  "brret", {opcode = "br.ret.sptk"; latency = 1; kind = KB; format = F_r};
-  "brcall", {opcode = "br.call.sptk.many"; latency = 1; kind = KB; format = F_i_r};
-  "brcallcond", {opcode = "br.call.spnt.many"; latency = 1; kind = KB; format = F_i_r_pred};
-  "brcallcondexc", {opcode = "br.call.spnt.many"; latency = 1; kind = KB_exc; format = F_i_r_pred};
-  "brcallind", {opcode = "br.call.sptk.many"; latency = 1; kind = KB; format = F_r_r};
-  "brcond", {opcode = "br.dpnt.many"; latency = 1; kind = KB; format = F_i_pred};
-  "brind", {opcode = "br.sptk.many"; latency = 1; kind = KB; format = F_r};
-  "cmp.eq", {opcode = "cmp.eq"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.ge", {opcode = "cmp.ge"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.geu", {opcode = "cmp.geu"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.gt", {opcode = "cmp.gt"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.gtu", {opcode = "cmp.gtu"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.le", {opcode = "cmp.le"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.leu", {opcode = "cmp.leu"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.lt", {opcode = "cmp.lt"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.ltu", {opcode = "cmp.ltu"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmp.ne", {opcode = "cmp.ne"; latency = 0; kind = KA; format = F_rr_rr};
-  "cmpi.eq", {opcode = "cmp.eq"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.ge", {opcode = "cmp.ge"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.geu", {opcode = "cmp.geu"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.gt", {opcode = "cmp.gt"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.gtu", {opcode = "cmp.gtu"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.le", {opcode = "cmp.le"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.leu", {opcode = "cmp.leu"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.lt", {opcode = "cmp.lt"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.ltu", {opcode = "cmp.ltu"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpi.ne", {opcode = "cmp.ne"; latency = 0; kind = KA; format = F_ir_rr};
-  "cmpp.eq", {opcode = "cmp.eq"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.ge", {opcode = "cmp.ge"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.geu", {opcode = "cmp.geu"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.gt", {opcode = "cmp.gt"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.gtu", {opcode = "cmp.gtu"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.le", {opcode = "cmp.le"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.leu", {opcode = "cmp.leu"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.lt", {opcode = "cmp.lt"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.ltu", {opcode = "cmp.ltu"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.ne", {opcode = "cmp.ne"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmpp.ne.and", {opcode = "cmp.ne.and"; latency = 1; kind = KA; format = F_rr_rr};
-  "cmppi.eq", {opcode = "cmp.eq"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.ge", {opcode = "cmp.ge"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.geu", {opcode = "cmp.geu"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.gt", {opcode = "cmp.gt"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.gtu", {opcode = "cmp.gtu"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.le", {opcode = "cmp.le"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.leu", {opcode = "cmp.leu"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.lt", {opcode = "cmp.lt"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.ltu", {opcode = "cmp.ltu"; latency = 1; kind = KA; format = F_ir_rr};
-  "cmppi.ne", {opcode = "cmp.ne"; latency = 1; kind = KA; format = F_ir_rr};
-  "extr.u", {opcode = "extr.u"; latency = 1; kind = KI; format = F_ri_r};
-  "fabs", {opcode = "fabs"; latency = 1; kind = KF; format = F_r_r};
-  "fadd.d", {opcode = "fadd.d"; latency = 5; kind = KF; format = F_rr_r};
-  "fcmp.eq", {opcode = "fcmp.eq"; latency = 1; kind = KF; format = F_rr_rr};
-  "fcmp.ge", {opcode = "fcmp.ge"; latency = 1; kind = KF; format = F_rr_rr};
-  "fcmp.gt", {opcode = "fcmp.gt"; latency = 1; kind = KF; format = F_rr_rr};
-  "fcmp.le", {opcode = "fcmp.le"; latency = 1; kind = KF; format = F_rr_rr};
-  "fcmp.lt", {opcode = "fcmp.lt"; latency = 1; kind = KF; format = F_rr_rr};
-  "fcmp.neq", {opcode = "fcmp.neq"; latency = 1; kind = KF; format = F_rr_rr};
-  "fcvt.fx.trunc", {opcode = "fcvt.fx.trunc"; latency = 7; kind = KF; format = F_r_r};
-  "fcvt.xf", {opcode = "fcvt.xf"; latency = 5; kind = KF; format = F_r_r};
-  "fma.d", {opcode = "fma.d"; latency = 5; kind = KF; format = F_rrr_r};
-  "fmacond", {opcode = "fma.d.s0"; latency = 5; kind = KF; format = F_rrr_r_pred};
-  "fmas1cond", {opcode = "fma.s1"; latency = 5; kind = KF; format = F_rrr_r_pred};
-  "fmads1cond", {opcode = "fma.d.s1"; latency = 5; kind = KF; format = F_rrr_r_pred};
-  "fmpy.d", {opcode = "fmpy.d"; latency = 5; kind = KF; format = F_rr_r};
-  "fms.d", {opcode = "fms.d"; latency = 5; kind = KF; format = F_rrr_r};
-  "fneg", {opcode = "fneg"; latency = 1; kind = KF; format = F_r_r};
-  "fnma.d", {opcode = "fnma.d"; latency = 5; kind = KF; format = F_rrr_r};
-  "fnmas1cond", {opcode = "fnma.s1"; latency = 5; kind = KF; format = F_rrr_r_pred};
-  "fnmads1cond", {opcode = "fnma.d.s1"; latency = 5; kind = KF; format = F_rrr_r_pred};
-  "fnorm.d", {opcode = "fnorm.d"; latency = 5; kind = KF; format = F_r_r};
-  "frcpa", {opcode = "frcpa.s0"; latency = 5; kind = KF; format = F_rr_rr};
-  "fsub.d", {opcode = "fsub.d"; latency = 5; kind = KF; format = F_rr_r};
-  "getf.sig", {opcode = "getf.sig"; latency = 2; kind = KM; format = F_r_r};
-  "ld1", {opcode = "ld1"; latency = 2; kind = KM; format = F_ld};
-  "ld2", {opcode = "ld2"; latency = 2; kind = KM; format = F_ld};
-  "ld4", {opcode = "ld4"; latency = 2; kind = KM; format = F_ld};
-  "ld8", {opcode = "ld8"; latency = 2; kind = KM; format = F_ld};
-  "ld8+", {opcode = "ld8"; latency = 2; kind = KM; format = F_ld_post};
-  "ldfd", {opcode = "ldfd"; latency = 9; kind = KM; format = F_ld};
-  "ldfd+", {opcode = "ldfd"; latency = 9; kind = KM; format = F_ld_post};
-  "ldfs", {opcode = "ldfs"; latency = 9; kind = KM; format = F_ld};
-  "mov", {opcode = "mov"; latency = 1; kind = KA; format = F_r_r};
-  "movcond", {opcode = "mov"; latency = 1; kind = KA; format = F_r_r_pred};
-  "movtb", {opcode = "mov"; latency = 9; kind = KI; format = F_r_r};
-  "movfb", {opcode = "mov"; latency = 2; kind = KI; format = F_r_r};
-  "movi", {opcode = "mov"; latency = 1; kind = KA; format = F_i_r};
-  "movicond", {opcode = "mov"; latency = 1; kind = KA; format = F_i_r_pred};
-  "movil", {opcode = "movl"; latency = 1; kind = KI; format = F_i_r};
-  "movpr", {opcode = "mov"; latency = 1; kind = KI; format = F_ri_r};
-  "or", {opcode = "or"; latency = 1; kind = KA; format = F_rr_r};
-  "ori", {opcode = "or"; latency = 1; kind = KA; format = F_ir_r};
-  "setf.d", {opcode = "setf.d"; latency = 8; kind = KM; format = F_r_r};
-  "setf.sig", {opcode = "setf.sig"; latency = 8; kind = KM; format = F_r_r};
-  "shl", {opcode = "shl"; latency = 2; kind = KI; format = F_rr_r};
-  "shladd", {opcode = "shladd"; latency = 1; kind = KA; format = F_r_rir};
-  "shli", {opcode = "shl"; latency = 1; kind = KI; format = F_ri_r};
-  "shr", {opcode = "shr"; latency = 2; kind = KI; format = F_rr_r};
-  "shri", {opcode = "shr"; latency = 1; kind = KI; format = F_ri_r};
-  "shru", {opcode = "shr.u"; latency = 2; kind = KI; format = F_rr_r};
-  "shrui", {opcode = "shr.u"; latency = 1; kind = KI; format = F_ri_r};
-  "st1", {opcode = "st1"; latency = 0; kind = KM; format = F_st};
-  "st2", {opcode = "st2"; latency = 0; kind = KM; format = F_st};
-  "st4", {opcode = "st4"; latency = 0; kind = KM; format = F_st};
-  "st8", {opcode = "st8"; latency = 0; kind = KM; format = F_st};
-  "st8+", {opcode = "st8"; latency = 1; kind = KM; format = F_st_post};
-  "stfd", {opcode = "stfd"; latency = 0; kind = KM; format = F_st};
-  "stfd+", {opcode = "stfd"; latency = 1; kind = KM; format = F_st_post};
-  "stfs", {opcode = "stfs"; latency = 0; kind = KM; format = F_st};
-  "sub", {opcode = "sub"; latency = 1; kind = KA; format = F_rr_r};
-  "sub1", {opcode = "sub"; latency = 1; kind = KA; format = F_rri_r};
-  "subi", {opcode = "sub"; latency = 1; kind = KA; format = F_ir_r};
-  "sxt1", {opcode = "sxt1"; latency = 1; kind = KI; format = F_r_r};
-  "sxt2", {opcode = "sxt2"; latency = 1; kind = KI; format = F_r_r};
-  "sxt4", {opcode = "sxt4"; latency = 1; kind = KI; format = F_r_r};
-  "tbit.nz", {opcode = "tbit.nz"; latency = 0; kind = KI; format = F_ri_rr};
-  "tbit.z", {opcode = "tbit.z"; latency = 0; kind = KI; format = F_ri_rr};
-  "xmpy.l", {opcode = "xmpy.l"; latency = 7; kind = KF; format = F_rr_r};
-  "xor", {opcode = "xor"; latency = 1; kind = KA; format = F_rr_r};
-  "xori", {opcode = "xor"; latency = 1; kind = KA; format = F_ir_r};
-  "#initbarrier", {opcode = "# init barrier"; latency = 0; kind = KI; format = F_i};
-]
-
-(* Nodes of the code DAG.  Each node represents one instruction to be
-   emitted. *)
-
-type code_dag_node =
-  { instr: instruction_descr;           (* the instruction *)
-    imm: string;                        (* its immediate argument, if any *)
-    iarg: resource array;               (* arguments *)
-    ires: resource array;               (* results *)
-    delay: int;               (* how many cycles before result is available *)
-    mutable sons: (code_dag_node * int) list;
-                                        (* nodes that depend on this node *)
-    mutable date: int;                  (* start date *)
-    mutable length: int;                (* length of longest path to result *)
-    mutable ancestors: int;             (* number of ancestors *)
-    mutable emitted_ancestors: int }    (* number of emitted ancestors *)
-
-(* The code dag itself is represented by two tables from resources to nodes:
-   - "results" maps resources to the instructions that produced them;
-   - "uses" maps resources to the instructions that use them. *)
-
-let code_results = (Hashtbl.create 31 : (resource, code_dag_node) Hashtbl.t)
-let code_uses = (Hashtbl.create 31 : (resource, code_dag_node) Hashtbl.t)
-
-let clear_code_dag () =
-  Hashtbl.clear code_results;
-  Hashtbl.clear code_uses
-
-(* The ready queue: a list of nodes that can be computed immediately
-   (all arguments are available), kept sorted by decreasing length to results.
-
-   The in progress queue: a list of nodes whose arguments are being computed,
-   and thus can be computed at a later date, kept sorted by increasing
-   availability date
-
-   The branch list: a list of all branch instructions (to be emitted last) *)
-
-let ready_queue = ref ([] : code_dag_node list)
-let in_progress_queue = ref ([] : code_dag_node list)
-let branch_list = ref ([] : code_dag_node list)  (* built in reverse order *)
-
-let clear_queues () =
-  ready_queue := []; in_progress_queue := []; branch_list := []
-
-let rec insert_queue prio node = function
-    [] -> [node]
-  | hd :: tl as queue ->
-      if prio node hd then node :: queue else hd :: insert_queue prio node tl
-
-let length_prio n1 n2 = n1.length > n2.length
-let date_prio n1 n2 = n1.date < n2.date
-
-let add_ready node =
-  ready_queue := insert_queue length_prio node !ready_queue
-let add_in_progress node =
-  in_progress_queue := insert_queue date_prio node !in_progress_queue
-let add_branch node =
-  branch_list := node :: !branch_list
-
-(* Add an edge to the code DAG *)
-
-let add_edge ancestor son delay =
-  ancestor.sons <- (son, delay) :: ancestor.sons;
-  son.ancestors <- son.ancestors + 1
-
-let add_edge_after son ancestor = add_edge ancestor son 0
-
-(* Add an instruction to the code DAG *)
-
-let insimm opc arg imm res =
-  let instr =
-    try
-      Hashtbl.find instruction_table opc
-    with Not_found ->
-      fatal_error ("Unknown instruction " ^ opc) in
-  let node =
-    { instr = instr;
-      imm = imm;
-      iarg = arg;
-      ires = res;
-      delay = instr.latency;
-      sons = [];                        (* to be filled later *)
-      date = 0;                         (* to be adjusted later *)
-      length = -1;                      (* to be computed later *)
-      ancestors = 0;                    (* ditto *)
-      emitted_ancestors = 0 } in        (* ditto *)
-  (* RAW dependencies: add edges from all instrs that define one of the
-     resources used *)
-  for i = 0 to Array.length arg - 1 do
-    try
-      let rsrc = arg.(i) in
-      if is_mutable_resource rsrc then begin
-        let anc = Hashtbl.find code_results rsrc in
-        let delay = if is_memory_resource rsrc then 0 else anc.delay in
-        (* Memory accesses are ordered by the hardware, so we can emit
-           a memop 1, then a dependent memop 2 in the same cycle *)
-        add_edge anc node delay
-      end
-    with Not_found ->
-      ()
-  done;
-  (* WAR dependencies: add edges from all instrs that use one of the
-     resources defined by this instruction
-     WAW dependencies: add edges from all instrs that define one of the
-     resources defined by this instruction *)
-  for i = 0 to Array.length res - 1 do
-    let rsrc = res.(i) in
-    if is_mutable_resource rsrc then begin
-      (* WAR *)
-      let anc = Hashtbl.find_all code_uses res.(i) in
-      List.iter (add_edge_after node) anc;
-      (* WAW *)
-      try
-        let anc = Hashtbl.find code_results rsrc in
-        let delay = if is_memory_resource rsrc then 0 else 1 in
-        add_edge anc node delay
-      with Not_found ->
-        ()
-    end
-  done;
-  (* Remember the results and uses of this instruction *)
-  for i = 0 to Array.length res - 1 do
-    Hashtbl.add code_results res.(i) node
-  done;
-  for i = 0 to Array.length arg - 1 do
-    Hashtbl.add code_uses arg.(i) node
-  done;
-  (* Insert in appropriate queue *)
-  if node.instr.kind = KB
-  then add_branch node
-  else if node.ancestors = 0 then add_ready node
-
-let insert opc arg res =
-  insimm opc arg "" res
-
-(* Compute length of longest path to a result. *)
-
-let rec longest_path node =
-  if node.length < 0 then begin
-    node.length <-
-      List.fold_left
-        (fun len (son, delay) -> max len (longest_path son + delay))
-        0 node.sons
-  end;
-  node.length
-
-(* Emit the assembly code for a node *)
-
-let emit_r = emit_string
-
-let emit_instr node =
-  let opc = node.instr.opcode
-  and a = node.iarg
-  and r = node.ires
-  and imm = node.imm in
-  match node.instr.format with
-    F_i ->
-        `      {emit_string opc}       {emit_string imm}\n`
-  | F_i_pred ->
-        `  ({emit_r a.(0)})    {emit_string opc}       {emit_string imm}\n`
-  | F_ir_rr ->
-        `      {emit_string opc}       {emit_r r.(0)}, {emit_r r.(1)} = {emit_string imm}, {emit_r a.(0)}\n`
-  | F_ir_r ->
-        `      {emit_string opc}       {emit_r r.(0)} = {emit_string imm}, {emit_r a.(0)}\n`
-  | F_ir_r_pred ->
-        `  ({emit_r a.(0)})    {emit_string opc}       {emit_r r.(0)} = {emit_string imm}, {emit_r a.(1)}\n`
-  | F_ld ->
-        `      {emit_string opc}       {emit_r r.(0)} = [{emit_r a.(0)}]\n`
-  | F_ld_post ->
-        `      {emit_string opc}       {emit_r r.(0)} = [{emit_r a.(0)}], {emit_string imm}\n`
-  | F_r ->
-        `      {emit_string opc}       {emit_r a.(0)}\n`
-  | F_i_r ->
-        `      {emit_string opc}       {emit_r r.(0)} = {emit_string imm}\n`
-  | F_i_r_pred ->
-        `  ({emit_r a.(0)})    {emit_string opc}       {emit_r r.(0)} = {emit_string imm}\n`
-  | F_ri_rr ->
-        `      {emit_string opc}       {emit_r r.(0)}, {emit_r r.(1)} = {emit_r a.(0)}, {emit_string imm}\n`
-  | F_ri_r ->
-        `      {emit_string opc}       {emit_r r.(0)} = {emit_r a.(0)}, {emit_string imm}\n`
-  | F_r_r ->
-        `      {emit_string opc}       {emit_r r.(0)} = {emit_r a.(0)}\n`
-  | F_r_r_pred ->
-        `  ({emit_r a.(0)})    {emit_string opc}       {emit_r r.(0)} = {emit_r a.(1)}\n`
-  | F_rr_rr ->
-        `      {emit_string opc}       {emit_r r.(0)}, {emit_r r.(1)} = {emit_r a.(0)}, {emit_r a.(1)}\n`
-  | F_r_rir ->
-        `      {emit_string opc}       {emit_r r.(0)} = {emit_r a.(0)}, {emit_string imm}, {emit_r a.(1)}\n`
-  | F_rr_r ->
-        `      {emit_string opc}       {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}\n`
-  | F_rr_r_pred ->
-        `  ({emit_r a.(0)})    {emit_string opc}       {emit_r r.(0)} = {emit_r a.(1)}, {emit_r a.(2)}\n`
-  | F_rri_r ->
-        `      {emit_string opc}       {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}, {emit_string imm}\n`
-  | F_rrr_r ->
-        `      {emit_string opc}       {emit_r r.(0)} = {emit_r a.(0)}, {emit_r a.(1)}, {emit_r a.(2)}\n`
-  | F_rrr_r_pred ->
-        `  ({emit_r a.(0)})    {emit_string opc}       {emit_r r.(0)} = {emit_r a.(1)}, {emit_r a.(2)}, {emit_r a.(3)}\n`
-  | F_st ->
-        `      {emit_string opc}       [{emit_r a.(0)}] = {emit_r a.(1)}\n`
-  | F_st_post ->
-        `      {emit_string opc}       [{emit_r a.(0)}] = {emit_r a.(1)}, {emit_string imm}\n`
-
-(* Little state machine reflecting how many instructions the chip can
-   issue in one cycle.  We roughly follow the Itanium model:
-   2 int units, 2 mem units, 2 FP units, and 3 branch units,
-   with a maximum of 6 instructions dispatched per clock cycle. *)
-
-let num_A = ref 0
-let num_I = ref 0
-let num_M = ref 0
-let num_F = ref 0
-let num_B = ref 0
-
-let reset_issue () =
-  num_A := 0; num_I := 0; num_M := 0; num_F := 0; num_B := 0
-
-let can_issue instr =
-  if !num_A + !num_I + !num_M + !num_F + !num_B >= 6 then false else begin
-    match instr.kind with
-      KA ->
-        if !num_A + !num_I + !num_M < 4
-        then (incr num_A; true)
-        else false
-    | KF ->
-        if !num_F < 2 then (incr num_F; true) else false
-    | KI ->
-        if !num_I < 2 && !num_A + !num_I + !num_M < 4
-        then (incr num_I; true) else false
-    | KM ->
-        if !num_M < 2 && !num_A + !num_I + !num_M < 4
-        then (incr num_M; true) else false
-    | _  (* KB | KB_exc *) ->
-        if !num_B < 3 then (incr num_B; true) else false
-  end
-
-(* Emit one node, updating the completion date and number of ancestors
-   emitted for all nodes that depend on this node.  Enter the nodes
-   that are no longer waiting on anything (all ancestors emitted)
-   in the ready queue or in the in_progress queue, depending on
-   latency. *)
-
-let emit_node date node =
-  begin try
-    (*`# Date: {emit_int date}; distance: {emit_int node.length}\n`;*)
-    emit_instr node
-  with x ->
-    fatal_error ("Error while emitting " ^ node.instr.opcode)
-  end;
-  List.iter
-    (fun (son, delay) ->
-      let completion_date = date + delay in
-      if son.date < completion_date then son.date <- completion_date;
-      son.emitted_ancestors <- son.emitted_ancestors + 1;
-      if son.emitted_ancestors = son.ancestors && son.instr.kind <> KB then
-      begin
-        (*`# {emit_string son.instr.opcode} will be ready at {emit_int son.date}\n`;*)
-        if son.date = date then add_ready son else add_in_progress son
-      end)
-    node.sons
-
-(* Emit all ready nodes that we can emit given the architectural
-   constraints. *)
-
-let rec emit_ready_nodes filter date =
-  match !ready_queue with
-    [] -> []
-  | node :: rem ->
-      ready_queue := rem;
-      if filter node && can_issue node.instr then begin
-        emit_node date node;
-        emit_ready_nodes filter date
-      end else
-        node :: emit_ready_nodes filter date
-
-let filter_MF node =
-  match node.instr.kind with KM -> true | KF -> true | _ -> false
-let filter_non_MF node =
-  not(filter_MF node)
-
-(* Add all instructions with date <= d to the ready queue, and remove them *)
-
-let rec extract_ready d = function
-    [] -> []
-  | node :: rem as queue ->
-      if node.date <= d then (add_ready node; extract_ready d rem) else queue
-
-(* Say if a branch is ready to be emitted now *)
-
-let branch_is_ready date br =
-  br.emitted_ancestors = br.ancestors && br.date <= date
-
-(* Schedule the basic block, emitting all of its instructions *)
-
-let rec reschedule date =
-  match (!ready_queue, !in_progress_queue) with
-    ([], []) ->
-      (* We're done with the regular instructions; finish with the branches *)
-      begin match !branch_list with
-        [] -> ()
-      | br -> List.iter emit_instr br; emit_string "  ;;\n"
-      end
-  | ([], node :: _) ->
-      (* Advance to the time node.date, extracting from in_progress_queue
-         all instructions ready at that time and adding them to the
-         ready queue *)
-      in_progress_queue := extract_ready node.date !in_progress_queue;
-      (* Try again *)
-      reschedule node.date
-  | (_, _) ->
-      `  # time {emit_int date}\n`;
-      (* Emit and remove as many ready instructions as we can *)
-      (* Give priority to M and F instructions *)
-      reset_issue();
-      ready_queue := emit_ready_nodes filter_MF date;
-      ready_queue := emit_ready_nodes filter_non_MF date;
-      (* Special hack: if the only remaining instructions are branches
-         and they are all ready now, emit them in the current
-         group of instructions *)
-      if !ready_queue = []
-      && !in_progress_queue = []
-      && List.for_all (branch_is_ready date) !branch_list
-      then begin
-        List.iter emit_instr !branch_list;
-        branch_list := []
-      end;
-      (* Emit a stop to pause the processor *)
-      emit_string "  ;;\n";
-      (* Advance to the time date + 1, extracting from in_progress_queue
-         all instructions ready at that time and adding them to the
-         ready queue *)
-      in_progress_queue := extract_ready (date + 1) !in_progress_queue;
-      (* Try again *)
-      reschedule (date + 1)
-
-(* Emit the code for the current basic block *)
-
-let end_basic_block () =
-  (* Compute critical paths and rebuild ready queue sorted by
-     decreasing criticality *)
-  let r = !ready_queue in
-  ready_queue := [];
-  let max_length =
-    List.fold_left (fun len node -> max len (longest_path node)) 0 r in
-  List.iter add_ready r;
-  branch_list := List.rev !branch_list;
-  (* Emit the instructions by traversing the code DAG *)
-  reschedule 0;
-  if max_length > 0 then `  # basic block length {emit_int max_length}\n`;
-  clear_code_dag ();
-  clear_queues ()
-
-(************** Part 2: the code emitter *******************)
-
-(* Tradeoff between code size and code speed *)
-
-let fastcode_flag = ref true
-
-(* Translate or output a label *)
-
-let label lbl = sprintf ".L%d" lbl
-
-let emit_label lbl = emit_string ".L"; emit_int lbl
-
-(* Translate or output a symbol *)
-
-let symbol s =
-  let b = Buffer.create (String.length s + 1) in
-  for i = 0 to String.length s - 1 do
-    let c = s.[i] in
-    match c with
-      'A'..'Z' | 'a'..'z' | '0'..'9' | '_' ->
-        Buffer.add_char b c
-    | _ ->
-        Buffer.add_string b (sprintf "$%02x" (Char.code c))
-  done;
-  Buffer.add_char b '#';
-  Buffer.contents b
-
-let emit_symbol s = Emitaux.emit_symbol '$' s
-
-(* Translate a pseudo-register *)
-
-let reg r =
-  match r.loc with Reg r -> register_name r | _ -> assert false
-
-let regs r =
-  Array.map reg r
-
-(* Output a pseudo-register *)
-
-let emit_reg r =
-  match r.loc with
-    Reg r -> emit_string (register_name r)
-  | _ -> fatal_error "Emit_ia64.emit_reg"
-
-(* Translate a float as a 64-bit integer *)
-
-let float_bits f =
-  let b = Buffer.create 18 in
-  let bytes = (Obj.magic f : string) in
-  Buffer.add_string b "0x";
-  for i = 7 downto 0 do (* little-endian *)
-    Buffer.add_string b
-       (sprintf "%02x" (Char.code (String.unsafe_get bytes i)))
-  done;
-  Buffer.contents b
-
-(* Translate an "ltoffset" reference to a global *)
-
-let ltoffset s = sprintf "@ltoff(%s)" (symbol s)
-let ltoffset_fptr s = sprintf "@ltoff(@fptr(%s))" (symbol s)
-
-(* Layout of the stack frame.
-   All stack offsets are shifted by 16 to preserve the scratch area at
-   bottom of stack. *)
-
-let stack_offset = ref 0
-
-let frame_size () =
-  let size =
-    !stack_offset +
-    8 * (num_stack_slots.(0) + num_stack_slots.(1)) +
-    (if !contains_calls then 8 else 0) in
-  Misc.align size 16
-
-let slot_offset loc cl =
-  match loc with
-    Incoming n -> frame_size() + n + 16
-  | Local n ->
-      if cl = 0
-      then !stack_offset + n * 8 + 16
-      else !stack_offset +  (num_stack_slots.(0) + n) * 8 + 16
-  | Outgoing n -> n + 16
-
-let slot_offset_reg r =
-  match r.loc with
-    Stack l -> slot_offset l (register_class r)
-  | _ -> assert false
-
-(* Record live pointers at call points *)
-
-type frame_descr =
-  { fd_lbl: int;                        (* Return address *)
-    fd_frame_size: int;                 (* Size of stack frame *)
-    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
-
-let frame_descriptors = ref([] : frame_descr list)
-
-let record_frame_label live =
-  let lbl = new_label() in
-  let live_offset = ref [] in
-  Reg.Set.iter
-    (function
-        {typ = Addr; loc = Reg r} ->
-          live_offset := ((r lsl 1) + 1) :: !live_offset
-      | {typ = Addr; loc = Stack s} as reg ->
-          live_offset := slot_offset s (register_class reg) :: !live_offset
-      | _ -> ())
-    live;
-  frame_descriptors :=
-    { fd_lbl = lbl;
-      fd_frame_size = frame_size();
-      fd_live_offset = !live_offset } :: !frame_descriptors;
-  lbl
-
-let record_frame live =
-  let lbl = record_frame_label live in `{emit_label lbl}:`
-
-let emit_frame fd =
-  `    data8   {emit_label fd.fd_lbl}\n`;
-  `    data2   {emit_int fd.fd_frame_size}\n`;
-  `    data2   {emit_int (List.length fd.fd_live_offset)}\n`;
-  List.iter
-    (fun n ->
-      `        data2   {emit_int n}\n`)
-    fd.fd_live_offset;
-  `    .align  8\n`
-
-(* Names of various instructions *)
-
-let name_for_int_operation = function
-    Iadd -> "add"
-  | Isub -> "sub"
-  | Iand -> "and"
-  | Ior -> "or"
-  | Ixor -> "xor"
-  | Ilsl -> "shl"
-  | Ilsr -> "shru"
-  | Iasr -> "shr"
-  | _ -> Misc.fatal_error "Emit.name_for_int_operation"
-
-let name_for_float_operation = function
-    Inegf -> "fneg"
-  | Iabsf -> "fabs"
-  | Iaddf -> "fadd.d"
-  | Isubf -> "fsub.d"
-  | Imulf -> "fmpy.d"
-  | _ -> Misc.fatal_error "Emit.name_for_float_operation"
-
-let name_for_specific_operation = function
-    Imultaddf -> "fma.d"
-  | Imultsubf -> "fms.d"
-  | Isubmultf -> "fnma.d"
-  | _ -> Misc.fatal_error "Emit.name_for_specific_operation"
-
-let name_for_int_comparison = function
-    Isigned Ceq -> "eq"     | Isigned Cne -> "ne"
-  | Isigned Cle -> "le"     | Isigned Cgt -> "gt"
-  | Isigned Clt -> "lt"     | Isigned Cge -> "ge"
-  | Iunsigned Ceq -> "eq"   | Iunsigned Cne -> "ne"
-  | Iunsigned Cle -> "leu"  | Iunsigned Cgt -> "gtu"
-  | Iunsigned Clt -> "ltu"  | Iunsigned Cge -> "geu"
-
-let name_for_swapped_int_comparison = function
-    Isigned Ceq -> "eq"     | Isigned Cne -> "ne"
-  | Isigned Cle -> "ge"     | Isigned Cgt -> "lt"
-  | Isigned Clt -> "gt"     | Isigned Cge -> "le"
-  | Iunsigned Ceq -> "eq"   | Iunsigned Cne -> "ne"
-  | Iunsigned Cle -> "geu"  | Iunsigned Cgt -> "ltu"
-  | Iunsigned Clt -> "gtu"  | Iunsigned Cge -> "leu"
-
-let name_for_float_comparison cmp =
-  match cmp with
-    Ceq -> "eq"  | Cne -> "neq"
-  | Cle -> "le"  | Cgt -> "gt"
-  | Clt -> "lt"  | Cge -> "ge"
-
-(* Immediate range for addl (move) and adds (general add) instructions *)
-
-let is_immediate_addl n = n >= -0x200000 && n < 0x200000
-let is_immediate_addl_nat n =
-  n >= Nativeint.of_int (-0x200000) && n < Nativeint.of_int 0x200000
-let is_immediate_adds n = n >= -0x2000 && n < 0x2000
-
-(* Return the positions of all "1" bits in the given integer,
-   most significant bits first *)
-
-let ones_pos n =
-  let rec ones p accu =
-    if p >= 63
-    then accu
-    else ones (p+1) (if n land (1 lsl p) = 0 then accu else p :: accu) in
-  ones 0 []
-
-(* Generate temporary registers *)
-
-let temp_generator temporaries =
-  let counter = ref 0 in
-  fun () ->
-    let r = temporaries.(!counter) in
-    incr counter;
-    if !counter >= Array.length temporaries then counter := 0;
-    r
-
-let new_temp_reg =
-  temp_generator [| "r2"; "r3"; "r14"; "r15" |]
-let new_temp_float =
-  temp_generator [| "f64"; "f65"; "f66"; "f67";
-                    "f68"; "f69"; "f70"; "f71" |]
-let new_pred =
-  temp_generator [| "p2"; "p3"; "p4"; "p5" |]
-
-(* Output the assembly code for an instruction *)
-
-(* Name of current function *)
-let function_name = ref ""
-(* Entry point for tail recursive calls *)
-let tailrec_entry_point = ref 0
-
-let emit_instr i =
-    match i.desc with
-      Lend -> ()
-    | Lop(Imove | Ispill | Ireload) ->
-        let src = i.arg.(0) and dst = i.res.(0) in
-        if src.loc <> dst.loc then begin
-          match (src.loc, dst.loc) with
-            (Reg _, Reg _) ->
-              insert "mov" (regs i.arg) (regs i.res)
-          | (Reg _, Stack _) ->
-              let offset = string_of_int (slot_offset_reg dst) in
-              let r = new_temp_reg() in
-              insimm "addi" [| "sp" |] offset [| r |];
-              insert (if i.res.(0).typ = Float then "stfd" else "st8")
-                     [| r; reg src |] [| "stk" ^ offset |]
-          | (Stack _, Reg _) ->
-              let offset = string_of_int (slot_offset_reg src) in
-              let r = new_temp_reg() in
-              insimm "addi" [| "sp" |] offset [| r |];
-              insert (if i.arg.(0).typ = Float then "ldfd" else "ld8")
-                     [| r; "stk" ^ offset |] (regs i.res)
-          | (_, _) ->
-              assert false
-        end
-    | Lop(Iconst_int n) ->
-        let instr =
-          if is_immediate_addl_nat n then "movi" else "movil" in
-        insimm instr [||] (Nativeint.to_string n) (regs i.res)
-    | Lop(Iconst_float s) ->
-       let f = float_of_string s in
-        begin match Int64.bits_of_float f with
-        | 0x0000_0000_0000_0000L ->       (* +0.0 *)
-            insert "mov" [| "f0" |] (regs i.res)
-        | 0x3FF0_0000_0000_0000L ->       (*  1.0 *)
-            insert "mov" [| "f1" |] (regs i.res)
-        | _ ->
-            let tmp = new_temp_reg() in
-            insimm "movil" [||] (float_bits f) [| tmp |];
-            insert "setf.d" [| tmp |] (regs i.res)
-        end
-    | Lop(Iconst_symbol s) ->
-        insimm "addi" [| "gp" |] (ltoffset s) (regs i.res);
-        insert "ld8" (regs i.res) (regs i.res)
-    | Lop(Icall_ind) ->
-        insert "movtb" (regs i.arg) [| "b0" |];
-        insert "brcallind" [| "b0" |] [| "b0" |];
-        end_basic_block();
-        `{record_frame i.live}\n`
-    | Lop(Icall_imm s) ->
-        insimm "brcall" [||] (symbol s) [| "b0" |];
-        end_basic_block();
-        `{record_frame i.live}\n`
-    | Lop(Itailcall_ind) ->
-        let n = frame_size() in
-        insert "movtb" (regs i.arg) [| "b6" |];
-        if !contains_calls then begin
-          let tmp = new_temp_reg() in
-          insimm "addi" [| "sp" |] (string_of_int (n + 8)) [| tmp |];
-          insert "ld8" [| tmp |] [| tmp |];
-          insert "mov" [| tmp |] [| "b0" |]
-        end;
-        if n > 0 then
-          insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |];
-        insert "brind" [| "b6" |] [||];
-        end_basic_block()
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name then begin
-          insimm "br" [||] (label !tailrec_entry_point) [||]
-        end else begin
-          let n = frame_size() in
-          if !contains_calls then begin
-            let tmp = new_temp_reg() in
-            insimm "addi" [| "sp" |] (string_of_int (n + 8)) [| tmp |];
-            insert "ld8" [| tmp |] [| tmp |];
-            insert "mov" [| tmp |] [| "b0" |]
-          end;
-          if n > 0 then
-            insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |];
-          insimm "br" [||] (symbol s) [||]
-        end;
-        end_basic_block()
-    | Lop(Iextcall(s, alloc)) ->
-        if alloc then begin
-          let tmp = new_temp_reg() in
-          insimm "addi" [| "gp" |] (ltoffset_fptr s) [| tmp |];
-          insert "ld8" [| tmp |] [| "r2" |];
-          insimm "brcall" [||] "caml_c_call#" [| "b0" |];
-          end_basic_block();
-          `{record_frame i.live}\n`
-        end else begin
-          insert "mov" [| "gp" |] [| "r7" |];
-          insimm "brcall" [||] (symbol s) [| "b0" |];
-          end_basic_block();
-          insert "mov" [| "r7" |] [| "gp" |]
-        end
-    | Lop(Istackoffset n) ->
-        end_basic_block();
-        insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |];
-        stack_offset := !stack_offset + n
-    | Lop(Iload(chunk, addr)) ->
-        let load_instr =
-          match chunk with
-          | Byte_unsigned -> "ld1"
-          | Byte_signed -> "ld1"
-          | Sixteen_unsigned -> "ld2"
-          | Sixteen_signed -> "ld2"
-          | Thirtytwo_unsigned -> "ld4"
-          | Thirtytwo_signed -> "ld4"
-          | Word -> "ld8"
-          | Single -> "ldfs"
-          | Double -> "ldfd"
-          | Double_u -> "ldfd" in
-        insert load_instr [| reg i.arg.(0); "heap" |] (regs i.res);
-        let sext_instr =
-          match chunk with
-            Byte_signed -> "sxt1"
-          | Sixteen_signed -> "sxt2"
-          | Thirtytwo_signed -> "sxt4"
-          | _ -> "" in
-        if sext_instr <> "" then
-          insert sext_instr (regs i.res) (regs i.res)
-    | Lop(Istore(chunk, addr)) ->
-        let store_instr =
-          match chunk with
-          | Byte_unsigned -> "st1"
-          | Byte_signed -> "st1"
-          | Sixteen_unsigned -> "st2"
-          | Sixteen_signed -> "st2"
-          | Thirtytwo_unsigned -> "st4"
-          | Thirtytwo_signed -> "st4"
-          | Word -> "st8"
-          | Single -> "stfs"
-          | Double -> "stfd"
-          | Double_u -> "stfd" in
-        insert store_instr [| reg i.arg.(1); reg i.arg.(0) |] [| "heap" |]
-    | Lop(Ialloc n) ->
-        if !fastcode_flag then begin
-          insimm "addi" [| "r4" |] (string_of_int (-n)) [| "r4" |];
-          insert "cmp.ltu" [| "r4"; "r5" |] [| "p6"; "p0" |];
-          insimm "movi" [||] (string_of_int n) [| "r2" |];
-          insimm "brcallcond" [| "p6" |] "caml_call_gc#" [| "b0" |];
-          end_basic_block();
-          `{record_frame i.live}\n`;
-          insimm "addi" [| "r4" |] "8" (regs i.res)
-        end else begin
-          insimm "movi" [||] (string_of_int n) [| "r2" |];
-          insimm "brcall" [||] "caml_allocN#" [| "b0" |];
-          end_basic_block();
-          `{record_frame i.live}\n`;
-          insimm "addi" [| "r4" |] "8" (regs i.res)
-        end
-    | Lop(Iintop Imul) ->
-        let t1 = new_temp_float() and t2 = new_temp_float() in
-        insert "setf.sig" [|reg i.arg.(0)|] [| t1 |];
-        insert "setf.sig" [|reg i.arg.(1)|] [| t2 |];
-        insert "xmpy.l" [| t1; t2 |] [| t1 |];
-        insert "getf.sig" [| t1 |] (regs i.res)
-    | Lop(Iintop(Icomp cmp)) ->
-        let comp = "cmpp." ^ name_for_int_comparison cmp in
-        let p1 = new_pred() and p2 = new_pred() in
-        insert comp (regs i.arg) [| p1; p2 |];
-        insimm "movicond" [| p1 |] "1" (regs i.res);
-        insimm "movicond" [| p2 |] "0" (regs i.res)
-    | Lop(Iintop(Icheckbound)) ->
-        insert "cmp.leu" (regs i.arg) [| "p6"; "p0" |];
-        insimm "brcallcondexc" [| "p6" |] "caml_ml_array_bound_error#"
-                               [| "b0"; "heap" |]
-    | Lop(Iintop op) ->
-        let instr = name_for_int_operation op in
-        insert instr (regs i.arg) (regs i.res)
-    | Lop(Iintop_imm(Imul, n)) ->
-        let src = reg i.arg.(0) and dst = reg i.res.(0) in
-        begin match ones_pos n with
-          [] ->
-            insimm "movi" [||] "0" [|dst|]
-        | [n] ->
-            insimm "shli" [|src|] (string_of_int n) [|dst|]
-        | [n; 0] when n <= 4 ->
-            insimm "shladd" [|src; src|] (string_of_int n) [|dst|]
-        | n1::n2::lst ->
-            let acc1 = new_temp_reg() and acc2 = new_temp_reg()
-            and tmp1 = new_temp_reg() and tmp2 = new_temp_reg() in
-            insimm "shli" [|src|] (string_of_int n1) [|acc1|];
-            insimm "shli" [|src|] (string_of_int n2) [|acc2|];
-            let rec add_shifts a1 t1 a2 t2 = function
-              [] ->
-                insert "add" [|a1; a2|] [|dst|]
-            | n::rem ->
-                if n = 0 then
-                  insert "add" [|src; a1|] [|a1|]
-                else if n <= 4 then
-                  insimm "shladd" [|src; a1|] (string_of_int n) [|a1|]
-                else begin
-                  insimm "shli" [|src|] (string_of_int n) [|t1|];
-                  insert "add" [|t1; a1|] [|a1|]
-                end;
-                add_shifts a2 t2 a1 t1 rem in
-            add_shifts acc1 tmp1 acc2 tmp2 lst
-        end
-    | Lop(Iintop_imm(Idiv, n)) -> (* n must be a power of 2 *)
-        let src = regs i.arg and dst = regs i.res in
-        let p1 = new_pred() and p2 = new_pred() in
-        let l = Misc.log2 n in
-        insert "cmpp.lt" [| src.(0); "r0" |] [| p1; p2 |];
-        if is_immediate_adds (n-1) then
-          insimm "addicond" [| p1; src.(0) |] (string_of_int (n-1)) dst
-        else begin
-          let moveop = if is_immediate_addl (n-1) then "movi" else "movil" in
-          insimm moveop [||] (string_of_int (n-1)) [| "r2" |];
-          insert "addcond" [| p1; src.(0); "r2" |] dst
-        end;
-        insert "movcond" [| p2; src.(0) |] dst;
-        insimm "shri" dst (string_of_int l) dst
-    | Lop(Iintop_imm(Imod, n)) -> (* n must be a power of 2 *)
-        let src = regs i.arg and dst = regs i.res in
-        let p = new_pred() in
-        let l = Misc.log2 n in
-        insert "cmpp.lt" [| src.(0); "r0" |] [| p; "p0" |];
-        insimm "extr.u" src (sprintf "0, %d" l) dst;
-        insert "cmpp.ne.and" [| dst.(0); "r0"; p |] [| p; "p0" |];
-        if is_immediate_adds (-n) then
-          insimm "addicond" [| p; dst.(0) |] (string_of_int (-n)) dst
-        else begin
-          let moveop = if is_immediate_addl (-n) then "movi" else "movil" in
-          insimm moveop [||] (string_of_int (-n)) [| "r2" |];
-          insert "addcond" [| p; dst.(0); "r2" |] dst
-        end
-    | Lop(Iintop_imm(Icomp cmp, n)) ->
-        let comp = "cmppi." ^ name_for_swapped_int_comparison cmp in
-        let p1 = new_pred() and p2 = new_pred() in
-        insimm comp (regs i.arg) (string_of_int n) [| p1; p2 |];
-        insimm "movicond" [| p1 |] "1" (regs i.res);
-        insimm "movicond" [| p2 |] "0" (regs i.res)
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-        insimm "cmpi.geu" (regs i.arg) (string_of_int n) [| "p6"; "p0" |];
-        insimm "brcallcondexc" [| "p6" |] "caml_ml_array_bound_error#"
-                               [| "b0"; "heap" |]
-    | Lop(Iintop_imm(op, n)) ->
-        let instr = name_for_int_operation op ^ "i" in
-        insimm instr (regs i.arg) (string_of_int n) (regs i.res)
-    | Lop(Inegf | Iabsf | Iaddf | Isubf | Imulf as op) ->
-        let instr = name_for_float_operation op in
-        insert instr (regs i.arg) (regs i.res)
-    | Lop(Idivf) ->
-        (* Straight from the IA64 application developer's architecture guide,
-           section 13.3.3.1. Modified so that the destination may be equal
-           to one of the operands *)
-        let a = reg i.arg.(0) and b = reg i.arg.(1) and r = reg i.res.(0)
-        and t1 = new_temp_float() and t2 = new_temp_float()
-        and t3 = new_temp_float() and t4 = new_temp_float()
-        and p = new_pred() in
-        insert "frcpa" [| a; b |] [| t1; p |];
-        insert "fmas1cond" [| p; a; t1; "f0" |] [| t2 |];
-        insert "fnmas1cond" [| p; b; t1; "f1" |] [| t3 |];
-        insert "fmas1cond" [| p; t3; t3; t2 |] [| t2 |];
-        insert "fmas1cond" [| p; t3; t3; "f0" |] [| t4 |];
-        insert "fmas1cond" [| p; t3; t1; t1 |] [| t1 |];
-        insert "fmas1cond" [| p; t4; t2; t2 |] [| t2 |];
-        insert "fmas1cond" [| p; t4; t4; "f0" |] [| t3 |];
-        insert "fmas1cond" [| p; t4; t1; t1 |] [| t1 |];
-        insert "fmads1cond" [| p; t3; t2; t2 |] [| t2 |];
-        insert "fmas1cond" [| p; t3; t1; t1 |] [| t1 |];
-        insert "fnmads1cond" [| p; b; t2; a |] [| t3 |];
-        insert "mov" [| t1 |] [| r |];
-        insert "fmacond" [| p; t3; t1; t2 |] [| r |]
-    | Lop(Ifloatofint) ->
-        let src = regs i.arg and dst = regs i.res in
-        insert "setf.sig" src dst;
-        insert "fcvt.xf" dst dst;
-        insert "fnorm.d" dst dst
-    | Lop(Iintoffloat) ->
-        let src = regs i.arg and dst = regs i.res and tmp = new_temp_float() in
-        insert "fcvt.fx.trunc" src [| tmp |];
-        insert "getf.sig" [| tmp |] dst
-    | Lop(Ispecific(Iadd1)) ->
-        let s = if Array.length i.arg >= 2 then 1 else 0 in
-        insimm "add1" [| reg i.arg.(0); reg i.arg.(s) |] "1" (regs i.res)
-    | Lop(Ispecific(Isub1)) ->
-        insimm "sub1" (regs i.arg) "1" (regs i.res)
-    | Lop(Ispecific(Ishladd n)) ->
-        insimm "shladd" (regs i.arg) (string_of_int n) (regs i.res)
-    | Lop(Ispecific(Isignextend n)) ->
-        let op = "sxt" ^ string_of_int n in
-        insert op (regs i.arg) (regs i.res)
-    | Lop(Ispecific (Imultaddf | Imultsubf | Isubmultf as sop)) ->
-        let name = name_for_specific_operation sop in
-        insert name (regs i.arg) (regs i.res)
-    | Lop(Ispecific (Istoreincr n)) ->
-        let op = if i.arg.(1).typ = Float then "stfd+" else "st8+" in
-        insimm op [| reg i.arg.(0); reg i.arg.(1) |]
-                  (string_of_int n)
-                 [| reg i.res.(0); "heapinit" |]
-    | Lop(Ispecific Iinitbarrier) ->
-        insert "#initbarrier" [| "heapinit" |] [| "heap" |]
-    | Lreloadretaddr ->
-        let n = frame_size() + 8 in
-        let tmp = new_temp_reg() in
-        insimm "addi" [| "sp" |] (string_of_int n) [| tmp |];
-        insert "ld8" [| tmp |] [| tmp |];
-        insert "movtb" [| tmp |] [| "b0" |]
-    | Lreturn ->
-        let n = frame_size() in
-        if n > 0 then
-          insimm "addi" [| "sp" |] (string_of_int n) [| "sp" |];
-        insert "brret" [| "b0" |] [||];
-        end_basic_block()
-    | Llabel lbl ->
-        end_basic_block();
-        `{emit_label lbl}:\n`
-    | Lbranch lbl ->
-        insimm "br" [||] (label lbl) [||];
-        end_basic_block()
-    | Lcondbranch(tst, lbl) ->
-        begin match tst with
-          Itruetest ->
-            insimm "cmpi.ne" (regs i.arg) "0" [| "p6"; "p0" |]
-        | Ifalsetest ->
-            insimm "cmpi.eq" (regs i.arg) "0" [| "p6"; "p0" |]
-        | Iinttest cmp ->
-            let comp = "cmp." ^ name_for_int_comparison cmp in
-            insert comp (regs i.arg) [| "p6"; "p0" |]
-        | Iinttest_imm(cmp, n) ->
-            let comp = "cmpi." ^ name_for_swapped_int_comparison cmp in
-            insimm comp (regs i.arg) (string_of_int n) [| "p6"; "p0" |]
-        | Ifloattest(cmp, neg) ->
-            let comp = "fcmp." ^ name_for_float_comparison cmp in
-            insert comp (regs i.arg)
-                     (if neg then [| "p0"; "p6" |]
-                             else [| "p6"; "p0" |])
-        | Ioddtest ->
-            insimm "tbit.nz" (regs i.arg) "0" [| "p6"; "p0" |]
-        | Ieventest ->
-            insimm "tbit.z" (regs i.arg) "0" [| "p6"; "p0" |]
-        end;
-        insimm "brcond" [| "p6" |] (label lbl) [||];
-        end_basic_block()
-    | Lcondbranch3(lbl0, lbl1, lbl2) ->
-        end_basic_block();
-        let emit_compare n p = function
-          None -> ()
-        | Some lbl ->
-           `   cmp.eq  p{emit_int p}, p0 = {emit_int n}, {emit_reg i.arg.(0)}\n` in
-        let emit_branch p = function
-          None -> ()
-        | Some lbl ->
-           `  (p{emit_int p})  br {emit_label lbl}\n` in
-        emit_compare 0 5 lbl0; emit_compare 1 6 lbl1; emit_compare 2 7 lbl2;
-        emit_branch 5 lbl0; emit_branch 6 lbl1; emit_branch 7 lbl2;
-        `  ;;\n`
-    | Lswitch jumptbl ->
-        end_basic_block();
-        let numcases = Array.length jumptbl in
-        if numcases <= 9 then begin
-          for j = 0 to numcases / 3 do
-            let n = j * 3 in
-            for k = 0 to 2 do
-              if n + k < numcases - 1 then
-                `      cmp.eq  p{emit_int(k+5)}, p0 = {emit_int (n+k)}, {emit_reg i.arg.(0)}\n`
-            done;
-            for k = 0 to 2 do
-              if n + k < numcases - 1 then
-                `  (p{emit_int(k+5)})  br {emit_label jumptbl.(n+k)}\n`
-              else if n + k = numcases - 1 then
-                `      br {emit_label jumptbl.(n+k)}\n`
-            done;
-            `  ;;\n`
-          done
-        end else if numcases <= 47 then begin
-          `    mov     r2 = 1\n`;
-          `    cmp.eq  p6, p0 = 0, {emit_reg i.arg.(0)}\n`;
-          `  (p6)      br {emit_label jumptbl.(0)} ;;\n`;
-          `    shl     r2 = r2, {emit_reg i.arg.(0)}\n`;
-          `    cmp.eq  p7, p0 = 1, {emit_reg i.arg.(0)}\n`;
-          `  (p7)      br {emit_label jumptbl.(1)} ;;\n`;
-          `    mov     pr = r2, -1 ;;\n`;
-          for i = 2 to numcases - 1 do
-            `  (p{emit_int i}) br {emit_label jumptbl.(i)}\n`
-          done;
-          `  ;;\n`
-        end else begin
-          let lbl_jumptbl = new_label() in
-          let lbl_ip = new_label() in
-          `{emit_label lbl_ip}:        mov     r2 = ip ;;\n`;
-          `    add     r2 = {emit_label lbl_jumptbl} - {emit_label lbl_ip}, r2 ;;\n`;
-          `    shladd  r3 = {emit_reg i.arg.(0)}, 2, r2 ;;\n`;
-          `    ld4     r3 = [r3] ;;\n`;
-          `    sxt4    r3 = r3 ;;\n`;
-          `    add     r2 = r2, r3 ;;\n`;
-          `    mov     b6 = r2 ;;\n`;
-          `    br      b6 ;;\n`;
-          `    .align 4\n`;
-          `{emit_label lbl_jumptbl}:\n`;
-          for i = 0 to numcases - 1 do
-            `  data4   {emit_label jumptbl.(i)} - {emit_label lbl_jumptbl}\n`
-          done;
-          `    .align 16\n`
-        end
-    | Lsetuptrap lbl ->
-        end_basic_block();
-        let lbl_ip = new_label() in
-        let lbl_next = new_label() in
-        `{emit_label lbl_ip}:  mov     r2 = ip ;;\n`;
-        `      add     r2 = {emit_label lbl_next} - {emit_label lbl_ip}, r2\n`;
-        `      br.sptk {emit_label lbl} ;;\n`;
-        `{emit_label lbl_next}:\n`
-    | Lpushtrap ->
-        end_basic_block();
-        stack_offset := !stack_offset + 16;
-        (* Store trap pointer at sp, handler addr at sp+8,
-           and decrement sp by 16.  Remember, the bottom 16 bytes
-           of the stack must be left free. *)
-        `      add     r3 = 8, sp\n`;
-        `      st8     [sp] = r6, -16 ;;\n`;
-        `      st8     [r3] = r2\n`;
-        `      add     r6 = 16, sp ;;\n`
-    | Lpoptrap ->
-        end_basic_block();
-        `      add     sp = 16, sp ;;\n`;
-        `      ld8     r6 = [sp] ;;\n`;
-        stack_offset := !stack_offset - 16
-    | Lraise ->
-        end_basic_block();
-        `      mov     sp = r6\n`;
-        `      add     r2 = 8, r6\n`;
-        `      ld8     r6 = [r6] ;;\n`;
-        `      ld8     r2 = [r2] ;;\n`;
-        `      mov     b6 = r2 ;;\n`;
-        `      br      b6\n`
-
-let rec emit_all i =
-  match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next
-
-(* Check if a function contains a tail call to itself *)
-
-let rec is_tailrec i =
-  match i.desc with
-    Lend -> false
-  | Lop(Itailcall_imm s) when s = !function_name -> true
-  | _ -> is_tailrec i.next
-
-(* Emission of a function declaration *)
-
-let fundecl f =
-  function_name := f.fun_name;
-  fastcode_flag := f.fun_fast;
-  stack_offset := 0;
-  `    .text\n`;
-  `    .align  4\n`;
-  `    .global {emit_symbol f.fun_name}#\n`;
-  `    .proc   {emit_symbol f.fun_name}#\n`;
-  `{emit_symbol f.fun_name}:\n`;
-  let n = frame_size() in
-  if !contains_calls then begin
-    insert "movfb" [| "b0" |] [| "r2" |];
-    insimm "addi" [| "sp" |] "8" [| "r3" |];
-    insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |];
-    insert "st8" [| "r3"; "r2" |] [||]
-  end
-  else if n > 0 then
-    insimm "addi" [| "sp" |] (string_of_int (-n)) [| "sp" |];
-  if is_tailrec f.fun_body then begin
-    tailrec_entry_point := new_label();
-    end_basic_block();
-    `{emit_label !tailrec_entry_point}:\n`
-  end;
-  emit_all f.fun_body;
-  end_basic_block();
-  `    .endp   {emit_symbol f.fun_name}#\n`
-
-(* Emission of data *)
-
-let emit_global_symbol s =
-  `    .global {emit_symbol s}#\n`;
-  `    .type   {emit_symbol s}#, @object\n`;
-  `    .size   {emit_symbol s}#, 8\n`
-
-let emit_define_symbol s =
-  emit_global_symbol s;
-  `{emit_symbol s}:\n`
-
-let emit_item = function
-    Cglobal_symbol s ->
-      emit_global_symbol s
-  | Cdefine_symbol s ->
-      `{emit_symbol s}:\n`
-  | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)}:\n`
-  | Cint8 n ->
-      `        data1   {emit_int n}\n`
-  | Cint16 n ->
-      `        data2   {emit_int n}\n`
-  | Cint32 n ->
-      let n' = Nativeint.shift_right (Nativeint.shift_left n 32) 32 in
-      `        data4   {emit_nativeint n'}\n`
-  | Cint n ->
-      `        data8   {emit_nativeint n}\n`
-  | Csingle f ->
-      emit_float32_directive "data4" f
-  | Cdouble f ->
-      emit_float64_directive "data8" f
-  | Csymbol_address s ->
-      `        data8   {emit_symbol s}#\n`
-  | Clabel_address lbl ->
-      `        data8   {emit_label (100000 + lbl)}\n`
-  | Cstring s ->
-      emit_string_directive "  string  " s
-  | Cskip n ->
-      if n > 0 then `  .skip   {emit_int n}\n`
-  | Calign n ->
-      `        .align  {emit_int n}\n`
-
-let data l =
-  `    .data\n`;
-  `    .align 8\n`;
-  List.iter emit_item l
-
-(* Beginning / end of an assembly file *)
-
-let begin_assembly() =
-  `    .data\n`;
-  emit_define_symbol (Compilenv.make_symbol (Some "data_begin"));
-  `    .text\n`;
-  emit_define_symbol (Compilenv.make_symbol (Some "code_begin"))
-
-let end_assembly () =
-  `    .data\n`;
-  emit_define_symbol (Compilenv.make_symbol (Some "data_end"));
-  `    .text\n`;
-  emit_define_symbol (Compilenv.make_symbol (Some "code_end"));
-  `    .rodata\n`;
-  `    .align 8\n`;
-  emit_define_symbol (Compilenv.make_symbol (Some "frametable"));
-  `    data8   {emit_int (List.length !frame_descriptors)}\n`;
-  List.iter emit_frame !frame_descriptors;
-  frame_descriptors := []

diff --git a/asmcomp/ia64/proc.ml b/asmcomp/ia64/proc.ml
deleted file mode 100644 (file)
index 15311aa..0000000
--- a/asmcomp/ia64/proc.ml
+++ /dev/null
@@ -1,217 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Description of the IA64 processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Mach
-
-(* Instruction selection *)
-
-let word_addressed = false
-
-(* Registers available for register allocation *)
-
-(* Register map:
-    r0                      always 0
-    r1                      global pointer (gp)
-    r2 - r3                 temporaries (for the code generator)
-    r4                      allocation pointer
-    r5                      allocation limit
-    r6                      trap pointer
-    r7                      saved gp during C calls (preserved by C)
-    r8 - r11       0 - 3    function results
-    r12                     stack pointer
-    r13                     reserved by C (thread-specific data)
-    r14 - r15     80 - 81   temporaries (for accessing stack variables)
-    r16 - r31      4 - 19   general purpose
-    r32 - r63     20 - 51   function arguments
-    r64 - r91     52 - 79   general purpose
-    r92 - r95               used by C glue code
-
-  We do not use register windows, but instead allocate 64 "out" registers
-  (r32-r95) when entering Caml code.
-
-    f0                        always 0.0
-    f1                        always 1.0
-    f2 - f5       100 - 103   general purpose (preserved by C)
-    f6 - f7       104 - 105   general purpose
-    f8 - f15      106 - 113   function results
-    f16 - f31     114 - 129   function arguments (preserved by C)
-    f32 - f63     130 - 161   general purpose
-    f64 - f66                 temporaries
-    f67 - f127                unused
-*)
-
-let int_reg_name = [|
-  (* 0-3 *)    "r8"; "r9"; "r10"; "r11";
-  (* 4-19 *)   "r16"; "r17"; "r18"; "r19"; "r20"; "r21"; "r22"; "r23";
-               "r24"; "r25"; "r26"; "r27"; "r28"; "r29"; "r30"; "r31";
-  (* 20-51 *)  "r32"; "r33"; "r34"; "r35"; "r36"; "r37"; "r38"; "r39";
-               "r40"; "r41"; "r42"; "r43"; "r44"; "r45"; "r46"; "r47";
-               "r48"; "r49"; "r50"; "r51"; "r52"; "r53"; "r54"; "r55";
-               "r56"; "r57"; "r58"; "r59"; "r60"; "r61"; "r62"; "r63";
-  (* 52-79 *)  "r64"; "r65"; "r66"; "r67"; "r68"; "r69"; "r70"; "r71";
-               "r72"; "r73"; "r74"; "r75"; "r76"; "r77"; "r78"; "r79";
-               "r80"; "r81"; "r82"; "r83"; "r84"; "r85"; "r86"; "r87";
-               "r88"; "r89"; "r90"; "r91";
-  (* 80-81 *)  "r14"; "r15"
-|]
-
-let float_reg_name = [|
-  (* 0-13 *)   "f2"; "f3"; "f4"; "f5"; "f6"; "f7";
-               "f8"; "f9"; "f10"; "f11"; "f12"; "f13"; "f14"; "f15";
-  (* 14-29 *)  "f16"; "f17"; "f18"; "f19"; "f20"; "f21"; "f22"; "f23";
-               "f24"; "f25"; "f26"; "f27"; "f28"; "f29"; "f30"; "f31";
-  (* 30-61 *)  "f32"; "f33"; "f34"; "f35"; "f36"; "f37"; "f38"; "f39";
-               "f40"; "f41"; "f42"; "f43"; "f44"; "f45"; "f46"; "f47";
-               "f48"; "f49"; "f50"; "f51"; "f52"; "f53"; "f54"; "f55";
-               "f56"; "f57"; "f58"; "f59"; "f60"; "f61"; "f62"; "f63"
-|]
-
-let num_register_classes = 2
-
-let register_class r =
-  match r.typ with
-    Int -> 0
-  | Addr -> 0
-  | Float -> 1
-
-let num_available_registers = [| 80; 62 |]
-
-let first_available_register = [| 0; 100 |]
-
-let register_name r =
-  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
-
-let rotate_registers = true
-
-(* Representation of hard registers by pseudo-registers *)
-
-let hard_int_reg =
-  let v = Array.create 82 Reg.dummy in
-  for i = 0 to 81 do v.(i) <- Reg.at_location Int (Reg i) done;
-  v
-
-let hard_float_reg =
-  let v = Array.create 62 Reg.dummy in
-  for i = 0 to 61 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done;
-  v
-
-let all_phys_regs =
-  Array.append hard_int_reg hard_float_reg
-
-let phys_reg n =
-  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
-
-let stack_slot slot ty =
-  Reg.at_location ty (Stack slot)
-
-(* Calling conventions *)
-
-let calling_conventions first_int last_int first_float last_float
-                        lockstep make_stack arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let int = ref first_int in
-  let float = ref first_float in
-  let ofs = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-      Int | Addr as ty ->
-        if !int <= last_int then begin
-          loc.(i) <- phys_reg !int;
-          incr int;
-          if lockstep then incr float
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) ty;
-          ofs := !ofs + size_int
-        end
-    | Float ->
-        if !float <= last_float then begin
-          loc.(i) <- phys_reg !float;
-          incr float;
-          if lockstep then incr int
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) Float;
-          ofs := !ofs + size_float
-        end
-  done;
-  (loc, Misc.align !ofs 16)         (* Keep stack 16-aligned *)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
-
-let loc_arguments arg =
-  calling_conventions 20 51 114 129 false outgoing arg
-let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 20 51 114 129 false incoming arg in loc
-let loc_results res =
-  let (loc, ofs) = calling_conventions 0 3 106 113 false not_supported res
-  in loc
-(* Arguments in r32...r39, f8...f15
-   Results in r8...r11, f8...f15 *)
-let loc_external_arguments arg =
-  calling_conventions 20 27 106 113 true outgoing arg
-let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 3 106 113 false not_supported res
-  in loc
-let extcall_use_push = false
-
-let loc_exn_bucket = phys_reg 0         (* r8 *)
-
-(* Registers destroyed by operations *)
-
-let destroyed_at_c_call =    (* f2...f5, f16...f31 preserved by C *)
-  Array.append
-    hard_int_reg
-    (Array.of_list(List.map phys_reg
-        [100;101;102;103;104;105;106;107;108;109;110;111;112;113;
-         130;131;132;133;134;135;136;137;138;139;
-         140;141;142;143;144;145;146;147;148;149;
-         150;151;152;153;154;155;156;157;158;159;
-         160;161]))
-
-let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
-  | _ -> [||]
-
-let destroyed_at_raise = all_phys_regs
-
-(* Maximal register pressure *)
-
-let safe_register_pressure = function
-    Iextcall(_, _) -> 0
-  | _ -> 62
-let max_register_pressure = function
-    Iextcall(_, _) -> [| 0; 20 |]
-  | _ -> num_available_registers
-
-(* Layout of the stack *)
-
-let num_stack_slots = [| 0; 0 |]
-let contains_calls = ref false
-
-(* Calling the assembler *)
-
-let assemble_file infile outfile =
-  Ccomp.command (Config.asm ^ " -o " ^
-                 Filename.quote outfile ^ " " ^ Filename.quote infile)
-
-open Clflags;;
-open Config;;

diff --git a/asmcomp/ia64/reload.ml b/asmcomp/ia64/reload.ml
deleted file mode 100644 (file)
index 338c088..0000000
--- a/asmcomp/ia64/reload.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Reloading for the IA64. *)
-
-let fundecl f =
-  (new Reloadgen.reload_generic)#fundecl f

diff --git a/asmcomp/ia64/scheduling.ml b/asmcomp/ia64/scheduling.ml
deleted file mode 100644 (file)
index 9bed03a..0000000
--- a/asmcomp/ia64/scheduling.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Schedgen (* to create a dependency *)
-
-(* We don't schedule here on the linearized code, but instead schedule the
-   assembly code generated in Emit. *)
-
-let fundecl f = f

diff --git a/asmcomp/ia64/selection.ml b/asmcomp/ia64/selection.ml
deleted file mode 100644 (file)
index 6be4a18..0000000
--- a/asmcomp/ia64/selection.ml
+++ /dev/null
@@ -1,178 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 2000 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Instruction selection for the IA64 processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Mach
-
-(* Helper function for add selection *)
-
-let reassociate_add = function
-    [Cconst_int n; arg] ->
-        [arg; Cconst_int n]
-  | [Cop(Caddi, [arg1; Cconst_int n]); arg3] ->
-        [Cop(Caddi, [arg1; arg3]); Cconst_int n]
-  | [Cop(Caddi, [Cconst_int n; arg1]); arg3] ->
-        [Cop(Caddi, [arg1; arg3]); Cconst_int n]
-  | [arg1; Cop(Caddi, [Cconst_int n; arg3])] ->
-        [Cop(Caddi, [arg1; arg3]); Cconst_int n]
-  | [arg1; Cop(Caddi, [arg2; arg3])] ->
-        [Cop(Caddi, [arg1; arg2]); arg3]
-  | args -> args
-
-(* Helper function for mult-immediate selection *)
-
-let rec count_one_bits n =
-  if n = 0 then 0
-  else if n land 1 = 0 then count_one_bits (n lsr 1)
-  else 1 + count_one_bits (n lsr 1)
-
-class selector = object (self)
-
-inherit Selectgen.selector_generic as super
-
-(* Range of immediate arguments:
-     add                14-bit signed
-     sub                turned into add
-     sub reversed       8-bit signed
-     mul                at most 16 "one" bits
-     div, mod           powers of 2
-     and, or, xor       8-bit signed
-     lsl, lsr, asr      6-bit unsigned
-     cmp                8-bit signed
-   For is_immediate, we put 8-bit signed and treat adds specially
-   (selectgen already does the right thing for shifts) *)
-
-method is_immediate n = n >= -128 && n < 128
-
-method is_immediate_add n = n >= -8192 && n < 8192
-
-method select_addressing arg = (Iindexed, arg)
-
-method! select_operation op args =
-  let norm_op =
-    match op with Cadda -> Caddi | Csuba -> Csubi | _ -> op in
-  let norm_args =
-    match norm_op with Caddi -> reassociate_add args | _ -> args in
-  match (norm_op, norm_args) with
-  (* Recognize x + y + 1 and x - y - 1 *)
-  | (Caddi, [Cop(Caddi, [arg1; arg2]); Cconst_int 1]) ->
-      (Ispecific Iadd1, [arg1; arg2])
-  | (Caddi, [Cop(Clsl, [arg1; Cconst_int 1]); Cconst_int 1]) ->
-      (Ispecific Iadd1, [arg1])
-  | (Csubi, [Cop(Csubi, [arg1; arg2]); Cconst_int 1]) ->
-      (Ispecific Isub1, [arg1; arg2])
-  | (Csubi, [Cop(Csubi, [arg1; Cconst_int 1]); arg2]) ->
-      (Ispecific Isub1, [arg1; arg2])
-  (* Recognize add immediate *)
-  | (Caddi, [arg; Cconst_int n]) when self#is_immediate_add n ->
-      (Iintop_imm(Iadd, n), [arg])
-  (* Turn sub immediate into add immediate *)
-  | (Csubi, [arg; Cconst_int n]) when self#is_immediate_add (-n) ->
-      (Iintop_imm(Iadd, -n), [arg])
-  (* Recognize imm - arg *)
-  | (Csubi, [Cconst_int n; arg]) when self#is_immediate n ->
-      (Iintop_imm(Isub, n), [arg])
-  (* Recognize shift-add operations *)
-  | (Caddi, [arg2; Cop(Clsl, [arg1; Cconst_int(1|2|3|4 as shift)])]) ->
-      (Ispecific(Ishladd shift), [arg1; arg2])
-  | (Caddi, [Cop(Clsl, [arg1; Cconst_int(1|2|3|4 as shift)]); arg2]) ->
-      (Ispecific(Ishladd shift), [arg1; arg2])
-  (* Recognize truncation/normalization of 64-bit integers to 32 bits *)
-  | (Casr, [Cop(Clsl, [arg; Cconst_int 32]); Cconst_int 32]) ->
-      (Ispecific (Isignextend 4), [arg])
-  (* Recognize x * cst and cst * x *)
-  | (Cmuli, [arg; Cconst_int n]) ->
-      self#select_imul_imm arg n
-  | (Cmuli, [Cconst_int n; arg]) ->
-      self#select_imul_imm arg n
-  (* Prevent the recognition of (x / cst) and (x % cst) when cst is not
-     a power of 2, which do not correspond to an instruction.
-     Turn general division and modulus into calls to C library functions *)
-  | (Cdivi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) ->
-      (Iintop_imm(Idiv, n), [arg])
-  | (Cdivi, _) ->
-      (Iextcall("__divdi3", false), args)
-  | (Cmodi, [arg; Cconst_int n]) when n = 1 lsl (Misc.log2 n) && n <> 1 ->
-      (Iintop_imm(Imod, n), [arg])
-  | (Cmodi, _) ->
-      (Iextcall("__moddi3", false), args)
-  (* Recognize mult-add and mult-sub instructions *)
-  | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
-      (Ispecific Imultaddf, [arg1; arg2; arg3])
-  | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) ->
-      (Ispecific Imultaddf, [arg1; arg2; arg3])
-  | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) ->
-      (Ispecific Imultsubf, [arg1; arg2; arg3])
-  | (Csubf, [arg3; Cop(Cmulf, [arg1; arg2])]) ->
-      (Ispecific Isubmultf, [arg1; arg2; arg3])
-  (* Use default selector otherwise *)
-  | _ ->
-      super#select_operation op args
-
-method private select_imul_imm arg n =
-  if count_one_bits n <= 16
-  then (Iintop_imm(Imul, n), [arg])
-  else (Iintop Imul, [arg; Cconst_int n])
-
-(* To palliate the lack of addressing with displacement, multiple
-   stores to the address r are translated as follows
-   (t1 and t2 are two temp regs)
-      t1 := r - 8
-      t2 := r
-      compute data1 in reg1
-      compute data2 in reg2
-      store reg1 at t1 and increment t1 by 16
-      store reg2 at t2 and increment t2 by 16
-      compute data3 in reg3
-      compute data4 in reg4
-      store reg3 at t1 and increment t1 by 16
-      store reg4 at t2 and increment t2 by 16
-      ...
-    Note: we use two temp regs and perform stores by groups of 2
-    in order to expose more instruction-level parallelism. *)
-method! emit_stores env data regs_addr =
-  let t1 = Reg.create Addr and t2 = Reg.create Addr in
-  self#insert (Iop(Iintop_imm(Iadd, -8))) regs_addr [|t1|];
-  self#insert (Iop Imove) regs_addr [|t2|];
-  (* Store components by batch of 2 *)
-  let backlog = ref None in
-  let do_store r =
-    match !backlog with
-      None -> (* keep it for later *)
-        backlog := Some r
-    | Some r' -> (* store r' at t1 and r at t2 *)
-        self#insert (Iop(Ispecific(Istoreincr 16))) [| t1; r' |] [| t1 |];
-        self#insert (Iop(Ispecific(Istoreincr 16))) [| t2; r  |] [| t2 |];
-        backlog := None in
-  List.iter
-    (fun exp ->
-      match self#emit_expr env exp with
-        None -> assert false
-      | Some regs -> Array.iter do_store regs)
-    data;
-  (* Store the backlog if any *)
-  begin match !backlog with
-    None -> ()
-  | Some r -> self#insert (Iop(Ispecific(Istoreincr 16))) [| t1; r |] [| t1 |]
-  end;
-  (* Insert an init barrier *)
-  self#insert (Iop(Ispecific Iinitbarrier)) [||] [||]
-end
-
-let fundecl f = (new selector)#emit_fundecl f

diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml
index 30f17b725095a81b7610ba3c65a4d30190195ff7..f22672b55d989c5c796962ca13f3230a3b5eeb10 100644 (file)
--- a/asmcomp/interf.ml
+++ b/asmcomp/interf.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/interf.mli b/asmcomp/interf.mli
index 00f4df49814a2a934698c39691dd9a492db7ee57..9e16f83641a0f5e5a1dcc43b9465b297267d1aab 100644 (file)
--- a/asmcomp/interf.mli
+++ b/asmcomp/interf.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml
index 5833595ae6f49c8bb458af72bbbdc9becda1a073..8a5411876a22d79295c0074a796aa1b0fe7b8b04 100644 (file)
--- a/asmcomp/linearize.ml
+++ b/asmcomp/linearize.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -54,7 +54,8 @@ let has_fallthrough = function
 type fundecl =
   { fun_name: string;
     fun_body: instruction;
-    fun_fast: bool }
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t }
 
 (* Invert a test *)
 
@@ -264,4 +265,5 @@ let rec linear i n =
 let fundecl f =
   { fun_name = f.Mach.fun_name;
     fun_body = linear f.Mach.fun_body end_instr;
-    fun_fast = f.Mach.fun_fast }
+    fun_fast = f.Mach.fun_fast;
+    fun_dbg  = f.Mach.fun_dbg }

diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli
index aaf03184c2b25351d42e07f105d51c332c6aef25..9fbe14ddb0e5ff4ee8d70b97cf6e1a913ad1aac6 100644 (file)
--- a/asmcomp/linearize.mli
+++ b/asmcomp/linearize.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -49,6 +49,7 @@ val invert_test: Mach.test -> Mach.test
 type fundecl =
   { fun_name: string;
     fun_body: instruction;
-    fun_fast: bool }
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t }
 
 val fundecl: Mach.fundecl -> fundecl

diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml
index 4e743d646f1fdc87ca661826a5d58ace684d1179..74a034fb391963c7a8ceaf2ee56616756dd88e7a 100644 (file)
--- a/asmcomp/liveness.ml
+++ b/asmcomp/liveness.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/liveness.mli b/asmcomp/liveness.mli
index 3353b444391994137b0d5bf9767eb5538d1be447..8a25a27bc686cef78adc21d5a2dfe0defe6f496a 100644 (file)
--- a/asmcomp/liveness.mli
+++ b/asmcomp/liveness.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/m68k/README b/asmcomp/m68k/README
deleted file mode 100644 (file)
index fe5479d..0000000
--- a/asmcomp/m68k/README
+++ /dev/null
@@ -1,8 +0,0 @@
-As of Feb 4th 2000, the native-code compiler for the Motorola 680x0 is
-no longer maintained and thus deprecated.
-
-The only machines on which we could test this port (Sun 3, SunOS 4)
-here at INRIA are being retired, and were so slow that the port wasn't
-kept up-to-date with the remainder of the system.
-
-- Xavier Leroy, for the Objective Caml development team.

diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index 027550ab12a7197e6b958128ec0e349f809263e6..3d29bde11ba1e7925b22eb258d78414d23fcd34d 100644 (file)
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -79,7 +79,8 @@ type fundecl =
   { fun_name: string;
     fun_args: Reg.t array;
     fun_body: instruction;
-    fun_fast: bool }
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t }
 
 let rec dummy_instr =
   { desc = Iend;

diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index 438d15d2fc541ae703cb8763b256d5d0e9b00beb..05cc999b5364420e2c7115ce10e33c58593d1b4d 100644 (file)
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -79,7 +79,8 @@ type fundecl =
   { fun_name: string;
     fun_args: Reg.t array;
     fun_body: instruction;
-    fun_fast: bool }
+    fun_fast: bool;
+    fun_dbg : Debuginfo.t }
 
 val dummy_instr: instruction
 val end_instr: unit -> instruction

diff --git a/asmcomp/mips/arch.ml b/asmcomp/mips/arch.ml
deleted file mode 100644 (file)
index c174ef6..0000000
--- a/asmcomp/mips/arch.ml
+++ /dev/null
@@ -1,71 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Specific operations for the Mips processor *)
-
-open Misc
-open Format
-
-(* Machine-specific command-line options *)
-
-let command_line_options = []
-
-(* Addressing modes *)
-
-type addressing_mode =
-    Ibased of string * int              (* symbol + displ *)
-  | Iindexed of int                     (* reg + displ *)
-
-(* Specific operations *)
-
-type specific_operation = unit          (* none *)
-
-(* Sizes, endianness *)
-
-let big_endian =
-  match Config.system with
-    "ultrix" -> false
-  | "irix" -> true
-  | _ -> fatal_error "Arch_mips.big_endian"
-
-let size_addr = 4
-let size_int = 4
-let size_float = 8
-
-(* Operations on addressing modes *)
-
-let identity_addressing = Iindexed 0
-
-let offset_addressing addr delta =
-  match addr with
-    Ibased(s, n) -> Ibased(s, n + delta)
-  | Iindexed n -> Iindexed(n + delta)
-
-let num_args_addressing = function
-    Ibased(s, n) -> 0
-  | Iindexed n -> 1
-
-(* Printing operations and addressing modes *)
-
-let print_addressing printreg addr ppf arg =
-  match addr with
-  | Ibased(s, n) ->
-      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
-      fprintf ppf "\"%s\"%s" s idx
-  | Iindexed n ->
-      let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in
-      fprintf ppf "%a%s" printreg arg.(0) idx
-
-let print_specific_operation printreg op ppf arg =
-  fatal_error "Arch_mips.print_specific_operation"

diff --git a/asmcomp/mips/emit.mlp b/asmcomp/mips/emit.mlp
deleted file mode 100644 (file)
index 06915fd..0000000
--- a/asmcomp/mips/emit.mlp
+++ /dev/null
@@ -1,593 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Emission of Mips assembly code *)
-
-open Location
-open Misc
-open Cmm
-open Arch
-open Proc
-open Reg
-open Mach
-open Linearize
-open Emitaux
-
-(* Tradeoff between code size and code speed *)
-
-let fastcode_flag = ref true
-
-(* Output a label *)
-
-let emit_label lbl =
-  emit_string "$"; emit_int lbl
-
-(* Output a symbol *)
-
-let emit_symbol s =
-  Emitaux.emit_symbol '$' s
-
-(* Output a pseudo-register *)
-
-let emit_reg r =
-  match r.loc with
-    Reg r -> emit_string (register_name r)
-  | _ -> fatal_error "Emit_mips.emit_reg"
-
-(* Record if $gp is needed *)
-
-let uses_gp = ref false
-
-(* Layout of the stack frame *)
-
-let stack_offset = ref 0
-
-let frame_size () =
-  let size =
-    !stack_offset +
-    4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) +
-    (if !contains_calls then if !uses_gp then 8 else 4 else 0) in
-  Misc.align size 16
-
-let slot_offset loc cl =
-  match loc with
-    Incoming n -> frame_size() + n
-  | Local n ->
-      if cl = 0
-      then !stack_offset + num_stack_slots.(1) * 8 + n * 4
-      else !stack_offset + n * 8
-  | Outgoing n -> n
-
-(* Output a stack reference *)
-
-let emit_stack r =
-  match r.loc with
-    Stack s ->
-      let ofs = slot_offset s (register_class r) in `{emit_int ofs}($sp)`
-  | _ -> fatal_error "Emit_mips.emit_stack"
-
-(* Output an addressing mode *)
-
-let emit_addressing addr r n =
-  match addr with
-    Iindexed ofs ->
-      `{emit_int ofs}({emit_reg r.(n)})`
-  | Ibased(s, 0) ->
-      `{emit_symbol s}`
-  | Ibased(s, ofs) ->
-      `{emit_symbol s}`;
-      if ofs > 0 then ` + {emit_int ofs}`;
-      if ofs < 0 then ` - {emit_int(-ofs)}`
-
-(* Communicate live registers at call points to the assembler *)
-
-let int_reg_number =
-  [| 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19; 20; 21 |]
-
-let float_reg_number =
-  [| 0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 16; 17; 18; 19;
-     20; 21; 22; 23; 24; 25; 26; 27; 28; 29; 30 |]
-
-let liveregs instr extra_msk =
-  (* $22, $23, $30 always live *)
-  let int_mask = ref(0x00000302 lor extra_msk)
-  and float_mask = ref 0 in
-  let add_register = function
-      {loc = Reg r; typ = (Int | Addr)} ->
-        int_mask := !int_mask lor (1 lsl (31 - int_reg_number.(r)))
-    | {loc = Reg r; typ = Float} ->
-        float_mask := !float_mask lor (1 lsl (31 - float_reg_number.(r - 100)))
-    | _ -> () in
-  Reg.Set.iter add_register instr.live;
-  Array.iter add_register instr.arg;
-  emit_printf "        .livereg 0x%08x, 0x%08x\n" !int_mask !float_mask
-
-let live_25 = 1 lsl (31 - 25)
-let live_24 = 1 lsl (31 - 24)
-
-(* Record live pointers at call points *)
-
-type frame_descr =
-  { fd_lbl: int;                        (* Return address *)
-    fd_frame_size: int;                 (* Size of stack frame *)
-    fd_live_offset: int list }          (* Offsets/regs of live addresses *)
-
-let frame_descriptors = ref([] : frame_descr list)
-
-let record_frame live =
-  let lbl = new_label() in
-  let live_offset = ref [] in
-  Reg.Set.iter
-    (function
-        {typ = Addr; loc = Reg r} ->
-          live_offset := ((int_reg_number.(r) lsl 1) + 1) :: !live_offset
-      | {typ = Addr; loc = Stack s} as reg ->
-          live_offset := slot_offset s (register_class reg) :: !live_offset
-      | _ -> ())
-    live;
-  frame_descriptors :=
-    { fd_lbl = lbl;
-      fd_frame_size = frame_size();
-      fd_live_offset = !live_offset } :: !frame_descriptors;
-  `{emit_label lbl}:`
-
-let emit_frame fd =
-  `    .word   {emit_label fd.fd_lbl}\n`;
-  `    .half   {emit_int fd.fd_frame_size}\n`;
-  `    .half   {emit_int (List.length fd.fd_live_offset)}\n`;
-  List.iter
-    (fun n ->
-      `        .half   {emit_int n}\n`)
-    fd.fd_live_offset;
-  `    .align  2\n`
-
-(* Determine if $gp is used in the function *)
-
-let rec instr_uses_gp i =
-  match i.desc with
-    Lend -> false
-  | Lop(Iconst_symbol s) -> true
-  | Lop(Icall_imm s) -> true
-  | Lop(Itailcall_imm s) -> true
-  | Lop(Iextcall(_, _)) -> true
-  | Lop(Iload(_, Ibased(_, _))) -> true
-  | Lop(Istore(_, Ibased(_, _))) -> true
-  | Lop(Ialloc _) -> true
-  | Lop(Iintop(Icheckbound)) -> true
-  | Lop(Iintop_imm(Icheckbound, _)) -> true
-  | Lswitch jumptbl -> true
-  | _ -> instr_uses_gp i.next
-
-(* Names of various instructions *)
-
-let name_for_comparison = function
-    Isigned Ceq -> "eq" | Isigned Cne -> "ne" | Isigned Cle -> "le"
-  | Isigned Cge -> "ge" | Isigned Clt -> "lt" | Isigned Cgt -> "gt"
-  | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "leu"
-  | Iunsigned Cge -> "geu" | Iunsigned Clt -> "ltu" | Iunsigned Cgt -> "gtu"
-
-let name_for_float_comparison cmp neg =
-  match cmp with
-    Ceq -> ("eq", neg) | Cne -> ("eq", not neg)
-  | Cle -> ("le", neg) | Cge -> ("ult", not neg)
-  | Clt -> ("lt", neg) | Cgt -> ("ule", not neg)
-
-let name_for_int_operation = function
-    Iadd -> "addu"
-  | Isub -> "subu"
-  | Imul -> "mul"
-  | Idiv -> "div"
-  | Imod -> "rem"
-  | Iand -> "and"
-  | Ior  -> "or"
-  | Ixor -> "xor"
-  | Ilsl -> "sll"
-  | Ilsr -> "srl"
-  | Iasr -> "sra"
-  | Icomp cmp -> "s" ^ name_for_comparison cmp
-  | _ -> Misc.fatal_error "Emit.name_for_int_operation"
-
-let name_for_float_operation = function
-    Inegf -> "neg.d"
-  | Iabsf -> "abs.d"
-  | Iaddf -> "add.d"
-  | Isubf -> "sub.d"
-  | Imulf -> "mul.d"
-  | Idivf -> "div.d"
-  | _ -> Misc.fatal_error "Emit.name_for_float_operation"
-
-(* Output the assembly code for an instruction *)
-
-(* Name of current function *)
-let function_name = ref ""
-(* Entry point for tail recursive calls *)
-let tailrec_entry_point = ref 0
-(* Label of jump to caml_call_gc *)
-let call_gc_label = ref 0
-(* Label of trap for out-of-range accesses *)
-let range_check_trap = ref 0
-
-let emit_instr i =
-    match i.desc with
-      Lend -> ()
-    | Lop(Imove | Ispill | Ireload) ->
-        let src = i.arg.(0) and dst = i.res.(0) in
-        if src.loc <> dst.loc then begin
-          match (src, dst) with
-            {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} ->
-              `        move    {emit_reg dst}, {emit_reg src}\n`
-          | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} ->
-              `        mov.d   {emit_reg dst}, {emit_reg src}\n`
-          | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} ->
-              `        sw      {emit_reg src}, {emit_stack dst}\n`
-          | {loc = Reg rs; typ = Float}, {loc = Stack sd} ->
-              `        s.d     {emit_reg src}, {emit_stack dst}\n`
-          | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} ->
-              `        lw      {emit_reg dst}, {emit_stack src}\n`
-          | {loc = Stack ss; typ = Float}, {loc = Reg rd} ->
-              `        l.d     {emit_reg dst}, {emit_stack src}\n`
-          | _ ->
-              fatal_error "Emit_mips: Imove"
-        end
-    | Lop(Iconst_int n) ->
-        if n = 0n then
-          `    move    {emit_reg i.res.(0)}, $0\n`
-        else
-          `    li      {emit_reg i.res.(0)}, {emit_nativeint n}\n`
-    | Lop(Iconst_float s) ->
-        `      li.d    {emit_reg i.res.(0)}, {emit_string s}\n`
-    | Lop(Iconst_symbol s) ->
-        `      la      {emit_reg i.res.(0)}, {emit_symbol s}\n`
-    | Lop(Icall_ind) ->
-        `      move    $25, {emit_reg i.arg.(0)}\n`;
-        liveregs i live_25;
-        `      jal     {emit_reg i.arg.(0)}\n`;
-        `{record_frame i.live}\n`
-    | Lop(Icall_imm s) ->
-        liveregs i 0;
-        `      jal     {emit_symbol s}\n`;
-        `{record_frame i.live}\n`
-    | Lop(Itailcall_ind) ->
-        let n = frame_size() in
-        if !contains_calls then
-          `    lw      $31, {emit_int(n - 4)}($sp)\n`;
-        if !uses_gp then
-          `    lw      $gp, {emit_int(n - 8)}($sp)\n`;
-        if n > 0 then
-          `    addu    $sp, $sp, {emit_int n}\n`;
-        liveregs i 0;
-        `      move    $25, {emit_reg i.arg.(0)}\n`;
-        liveregs i live_25;
-        `      j       {emit_reg i.arg.(0)}\n`
-    | Lop(Itailcall_imm s) ->
-        if s = !function_name then begin
-          `    b       {emit_label !tailrec_entry_point}\n`
-        end else begin
-          let n = frame_size() in
-          if !contains_calls then
-            `  lw      $31, {emit_int(n - 4)}($sp)\n`;
-          if !uses_gp then
-            `  lw      $gp, {emit_int(n - 8)}($sp)\n`;
-          if n > 0 then
-            `  addu    $sp, $sp, {emit_int n}\n`;
-          `    la      $25, {emit_symbol s}\n`;
-          liveregs i live_25;
-          `    j       $25\n`
-        end
-    | Lop(Iextcall(s, alloc)) ->
-        if alloc then begin
-          `    la      $24, {emit_symbol s}\n`;
-          liveregs i live_24;
-          `    jal     caml_c_call\n`;
-          `{record_frame i.live}\n`
-        end else begin
-          `    jal     {emit_symbol s}\n`
-        end
-   | Lop(Istackoffset n) ->
-        if n >= 0 then
-          `    subu    $sp, $sp, {emit_int n}\n`
-        else
-          `    addu    $sp, $sp, {emit_int (-n)}\n`;
-        stack_offset := !stack_offset + n
-    | Lop(Iload(chunk, addr)) ->
-        let dest = i.res.(0) in
-        begin match chunk with
-          Double_u ->
-            (* Destination is not 8-aligned, hence cannot use l.d *)
-            `  ldl     $24, {emit_addressing addr i.arg 0}\n`;
-            `  ldr     $24, {emit_addressing (offset_addressing addr 7) i.arg 0}\n`;
-            `  dmtc1   $24, {emit_reg dest}\n`
-        | Single ->
-            `  l.s     {emit_reg dest}, {emit_addressing addr i.arg 0}\n`;
-            `  cvt.d.s {emit_reg dest}, {emit_reg dest}\n`
-        | _ ->
-            let load_instr =
-              match chunk with
-                Byte_unsigned -> "lbu"
-              | Byte_signed -> "lb"
-              | Sixteen_unsigned -> "lhu"
-              | Sixteen_signed -> "lh"
-              | Double -> "l.d"
-              | _ -> "lw" in
-            `  {emit_string load_instr}        {emit_reg dest}, {emit_addressing addr i.arg 0}\n`
-        end
-    | Lop(Istore(chunk, addr)) ->
-        let src = i.arg.(0) in
-        begin match chunk with
-          Double_u ->
-            (* Destination is not 8-aligned, hence cannot use l.d *)
-            `  dmfc1   $24, {emit_reg src}\n`;
-            `  sdl     $24, {emit_addressing addr i.arg 1}\n`;
-            `  sdr     $24, {emit_addressing (offset_addressing addr 7) i.arg 1}\n`
-        | Single ->
-            `  cvt.s.d $f31, {emit_reg src}\n`;
-            `  s.s     $f31, {emit_addressing addr i.arg 1}\n`
-        | _ ->
-            let store_instr =
-              match chunk with
-                Byte_unsigned | Byte_signed -> "sb"
-              | Sixteen_unsigned | Sixteen_signed -> "sh"
-              | Double -> "s.d"
-              | _ -> "sw" in
-            `  {emit_string store_instr}       {emit_reg src}, {emit_addressing addr i.arg 1}\n`
-        end
-    | Lop(Ialloc n) ->
-        if !call_gc_label = 0 then call_gc_label := new_label();
-        `      .set    noreorder\n`;
-        `      subu    $22, $22, {emit_int n}\n`;
-        `      subu    $24, $22, $23\n`;
-        `      bltzal  $24, {emit_label !call_gc_label}\n`;
-        `      addu    {emit_reg i.res.(0)}, $22, 4\n`;
-        `{record_frame i.live}\n`;
-        `      .set    reorder\n`
-    | Lop(Iintop(Icheckbound)) ->
-        if !range_check_trap = 0 then range_check_trap := new_label();
-        `      bleu    {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label !range_check_trap}\n`
-    | Lop(Iintop op) ->
-        let instr = name_for_int_operation op in
-        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
-    | Lop(Iintop_imm(Icheckbound, n)) ->
-        if !range_check_trap = 0 then range_check_trap := new_label();
-        `      bleu    {emit_reg i.arg.(0)}, {emit_int n}, {emit_label !range_check_trap}\n`
-    | Lop(Iintop_imm(op, n)) ->
-        let instr = name_for_int_operation op in
-        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n`
-    | Lop(Inegf | Iabsf as op) ->
-        let instr = name_for_float_operation op in
-        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`
-    | Lop(Iaddf | Isubf | Imulf | Idivf as op) ->
-        let instr = name_for_float_operation op in
-        `      {emit_string instr}     {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`
-    | Lop(Ifloatofint) ->
-        `      mtc1    {emit_reg i.arg.(0)}, {emit_reg i.res.(0)}\n`;
-        `      cvt.d.w {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n`
-    | Lop(Iintoffloat) ->
-        `      trunc.w.d       $f31, {emit_reg i.arg.(0)}, $24\n`;
-        `      mfc1    {emit_reg i.res.(0)}, $f31\n`
-    | Lop(Ispecific sop) ->
-        fatal_error "Emit_mips: Ispecific"
-    | Lreloadretaddr ->
-        let n = frame_size() in
-        `      lw      $31, {emit_int(n - 4)}($sp)\n`;
-    | Lreturn ->
-        let n = frame_size() in
-        if !uses_gp then
-          `    lw      $gp, {emit_int(n - 8)}($sp)\n`;
-        if n > 0 then
-          `    addu    $sp, $sp, {emit_int n}\n`;
-        liveregs i 0;
-        `      j       $31\n`
-    | Llabel lbl ->
-        `{emit_label lbl}:\n`
-    | Lbranch lbl ->
-        `      b       {emit_label lbl}\n`
-    | Lcondbranch(tst, lbl) ->
-        begin match tst with
-          Itruetest ->
-            `  bne     {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n`
-        | Ifalsetest ->
-            `  beq     {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n`
-        | Iinttest cmp ->
-            let comp = name_for_comparison cmp in
-            `  b{emit_string comp}     {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_label lbl}\n`
-        | Iinttest_imm(cmp, n) ->
-            let comp = name_for_comparison cmp in
-            `  b{emit_string comp}     {emit_reg i.arg.(0)}, {emit_int n}, {emit_label lbl}\n`
-        | Ifloattest(cmp, neg) ->
-            let (comp, branch) = name_for_float_comparison cmp neg in
-            `  c.{emit_string comp}.d  {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`;
-            if branch
-            then `     bc1f    {emit_label lbl}\n`
-            else `     bc1t    {emit_label lbl}\n`
-        | Ioddtest ->
-            `  and     $24, {emit_reg i.arg.(0)}, 1\n`;
-            `  bne     $24, $0, {emit_label lbl}\n`
-        | Ieventest ->
-            `  and     $24, {emit_reg i.arg.(0)}, 1\n`;
-            `  beq     $24, $0, {emit_label lbl}\n`
-        end
-  | Lcondbranch3(lbl0, lbl1, lbl2) ->
-        `      subu    $24, {emit_reg i.arg.(0)}, 1\n`;
-        begin match lbl0 with
-          None -> ()
-        | Some lbl -> `        beq     {emit_reg i.arg.(0)}, $0, {emit_label lbl}\n`
-        end;
-        begin match lbl1 with
-          None -> ()
-        | Some lbl -> `        beq     $24, $0, {emit_label lbl}\n`
-        end;
-        begin match lbl2 with
-          None -> ()
-        | Some lbl -> `        bgtz    $24, {emit_label lbl}\n`
-        end
-  | Lswitch jumptbl ->
-        let lbl_jumptbl = new_label() in
-        `      sll     $24, {emit_reg i.arg.(0)}, 2\n`;
-        `      lw      $24, {emit_label lbl_jumptbl}($24)\n`;
-        liveregs i live_24;
-        `      j       $24\n`;
-        `      .rdata\n`;
-        `{emit_label lbl_jumptbl}:\n`;
-        for i = 0 to Array.length jumptbl - 1 do
-          `    .word   {emit_label jumptbl.(i)}\n`
-        done;
-        `      .text\n`
-    | Lsetuptrap lbl ->
-        `      subu    $sp, $sp, 16\n`;
-        `      bal     {emit_label lbl}\n`
-    | Lpushtrap ->
-        stack_offset := !stack_offset + 16;
-        `      sw      $30, 0($sp)\n`;
-        `      sw      $31, 4($sp)\n`;
-        `      sw      $gp, 8($sp)\n`;
-        `      move    $30, $sp\n`
-    | Lpoptrap ->
-        `      lw      $30, 0($sp)\n`;
-        `      addu    $sp, $sp, 16\n`;
-        stack_offset := !stack_offset - 16
-    | Lraise ->
-        `      lw      $25, 4($30)\n`;
-        `      move    $sp, $30\n`;
-        `      lw      $30, 0($sp)\n`;
-        `      lw      $gp, 8($sp)\n`;
-        `      addu    $sp, $sp, 16\n`;
-        liveregs i live_25;
-        `      jal     $25\n` (* Keep retaddr in $31 for debugging *)
-
-let rec emit_all i =
-  match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next
-
-(* Emission of a function declaration *)
-
-let fundecl fundecl =
-  function_name := fundecl.fun_name;
-  fastcode_flag := fundecl.fun_fast;
-  uses_gp := instr_uses_gp fundecl.fun_body;
-  if !uses_gp then contains_calls := true;
-  tailrec_entry_point := new_label();
-  stack_offset := 0;
-  call_gc_label := 0;
-  range_check_trap := 0;
-  `    .text\n`;
-  `    .align  2\n`;
-  `    .globl  {emit_symbol fundecl.fun_name}\n`;
-  `    .ent    {emit_symbol fundecl.fun_name}\n`;
-  `{emit_symbol fundecl.fun_name}:\n`;
-  let n = frame_size() in
-  if n > 0 then
-    `  subu    $sp, $sp, {emit_int n}\n`;
-  if !contains_calls then
-    `  sw      $31, {emit_int(n - 4)}($sp)\n`;
-  if !uses_gp then begin
-    `  sw      $gp, {emit_int(n - 8)}($sp)\n`;
-    `  lui     $24, %hi(%neg(%gp_rel({emit_symbol fundecl.fun_name})))\n`;
-    `  addiu   $24, $24, %lo(%neg(%gp_rel({emit_symbol fundecl.fun_name})))\n`;
-    `  daddu   $gp, $25, $24\n`
-  end;
-  `{emit_label !tailrec_entry_point}:\n`;
-  emit_all fundecl.fun_body;
-  if !call_gc_label > 0 then begin
-    `{emit_label !call_gc_label}:\n`;
-    `  la      $25, caml_call_gc\n`;
-    `  j       $25\n`
-  end;
-  if !range_check_trap > 0 then begin
-    `{emit_label !range_check_trap}:\n`;
-    `  la      $25, caml_ml_array_bound_error\n`;
-    `  j       $25\n`
-  end;
-  `    .end    {emit_symbol fundecl.fun_name}\n`
-
-(* Emission of data *)
-
-let emit_item = function
-    Cglobal_symbol s ->
-      `        .globl  {emit_symbol s}\n`;
-  | Cdefine_symbol s ->
-      `{emit_symbol s}:\n`
-  | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)}:\n`
-  | Cint8 n ->
-      `        .byte   {emit_int n}\n`
-  | Cint16 n ->
-      `        .half   {emit_int n}\n`
-  | Cint32 n ->
-      `        .word   {emit_nativeint n}\n`
-  | Cint n ->
-      `        .word   {emit_nativeint n}\n`
-  | Csingle f ->
-      emit_float32_directive ".word" f
-  | Cdouble f ->
-      emit_float64_split_directive ".word" f
-  | Csymbol_address s ->
-      `        .word   {emit_symbol s}\n`
-  | Clabel_address lbl ->
-      `        .word   {emit_label (100000 + lbl)}\n`
-  | Cstring s ->
-      emit_string_directive "  .ascii  " s
-  | Cskip n ->
-      if n > 0 then `  .space  {emit_int n}\n`
-  | Calign n ->
-      `        .align  {emit_int(Misc.log2 n)}\n`
-
-let data l =
-  `    .data\n`;
-  List.iter emit_item l
-
-(* Beginning / end of an assembly file *)
-
-let begin_assembly() =
-  (* There are really two groups of registers:
-      $sp and $30 always point to stack locations
-      $2 - $21 never point to stack locations. *)
-  `    .noalias $2,$sp;  .noalias $2,$30;  .noalias $3,$sp;  .noalias $3,$30\n`;
-  `    .noalias $4,$sp;  .noalias $4,$30;  .noalias $5,$sp;  .noalias $5,$30\n`;
-  `    .noalias $6,$sp;  .noalias $6,$30;  .noalias $7,$sp;  .noalias $7,$30\n`;
-  `    .noalias $8,$sp;  .noalias $8,$30;  .noalias $9,$sp;  .noalias $9,$30\n`;
-  `    .noalias $10,$sp; .noalias $10,$30; .noalias $11,$sp; .noalias $11,$30\n`;
-  `    .noalias $12,$sp; .noalias $12,$30; .noalias $13,$sp; .noalias $13,$30\n`;
-  `    .noalias $14,$sp; .noalias $14,$30; .noalias $15,$sp; .noalias $15,$30\n`;
-  `    .noalias $16,$sp; .noalias $16,$30; .noalias $17,$sp; .noalias $17,$30\n`;
-  `    .noalias $18,$sp; .noalias $18,$30; .noalias $19,$sp; .noalias $19,$30\n`;
-  `    .noalias $20,$sp; .noalias $20,$30; .noalias $21,$sp; .noalias $21,$30\n\n`;
-  let lbl_begin = Compilenv.make_symbol (Some "data_begin") in
-  `    .data\n`;
-  `    .globl  {emit_symbol lbl_begin}\n`;
-  `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.make_symbol (Some "code_begin") in
-  `    .text\n`;
-  `    .globl  {emit_symbol lbl_begin}\n`;
-  `    .ent    {emit_symbol lbl_begin}\n`;
-  `{emit_symbol lbl_begin}:\n`;
-  `    .end    {emit_symbol lbl_begin}\n`
-
-let end_assembly () =
-  let lbl_end = Compilenv.make_symbol (Some "code_end") in
-  `    .text\n`;
-  `    .globl  {emit_symbol lbl_end}\n`;
-  `    .ent    {emit_symbol lbl_end}\n`;
-  `{emit_symbol lbl_end}:\n`;
-  `    .end    {emit_symbol lbl_end}\n`;
-  let lbl_end = Compilenv.make_symbol (Some "data_end") in
-  `    .data\n`;
-  `    .globl  {emit_symbol lbl_end}\n`;
-  `{emit_symbol lbl_end}:\n`;
-  `    .word   0\n`;
-  let lbl = Compilenv.make_symbol (Some "frametable") in
-  `    .rdata\n`;
-  `    .globl  {emit_symbol lbl}\n`;
-  `{emit_symbol lbl}:\n`;
-  `    .word   {emit_int (List.length !frame_descriptors)}\n`;
-  List.iter emit_frame !frame_descriptors;
-  frame_descriptors := []

diff --git a/asmcomp/mips/proc.ml b/asmcomp/mips/proc.ml
deleted file mode 100644 (file)
index 5397189..0000000
--- a/asmcomp/mips/proc.ml
+++ /dev/null
@@ -1,210 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Description of the Mips processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Mach
-
-(* Instruction selection *)
-
-let word_addressed = false
-
-(* Registers available for register allocation *)
-
-(* Register map:
-    $0                          always 0
-    $1                          temporary for the assembler
-    $2 - $7     0 - 5           function results
-    $8 - $15    6 - 13          function arguments
-    $16 - $21   14 - 19         general purpose (preserved by C)
-    $22                         allocation pointer (preserved by C)
-    $23                         allocation limit (preserved by C)
-    $24 - $25                   temporaries
-    $26 - $29                   kernel regs, stack pointer, global pointer
-    $30                         trap pointer (preserved by C)
-    $31                         return address
-
-    $f0 - $f3   100 - 103       function results
-    $f4 - $f11  104 - 111       general purpose
-    $f12 - $f19 112 - 119       function arguments
-    $f20 - $f30 120 - 130       general purpose (even numbered preserved by C)
-    $f31                        temporary *)
-
-let int_reg_name = [|
-  (* 0-5 *)    "$2"; "$3"; "$4"; "$5"; "$6"; "$7";
-  (* 6-13 *)   "$8"; "$9"; "$10"; "$11"; "$12"; "$13"; "$14"; "$15";
-  (* 14-19 *)  "$16"; "$17"; "$18"; "$19"; "$20"; "$21"
-|]
-
-let float_reg_name = [|
-  "$f0"; "$f1"; "$f2"; "$f3"; "$f4";
-  "$f5"; "$f6"; "$f7"; "$f8"; "$f9";
-  "$f10"; "$f11"; "$f12"; "$f13"; "$f14";
-  "$f15"; "$f16"; "$f17"; "$f18"; "$f19";
-  "$f20"; "$f21"; "$f22"; "$f23"; "$f24";
-  "$f25"; "$f26"; "$f27"; "$f28"; "$f29"; "$f30"
-|]
-
-let num_register_classes = 2
-
-let register_class r =
-  match r.typ with
-    Int -> 0
-  | Addr -> 0
-  | Float -> 1
-
-let num_available_registers = [| 20; 31 |]
-
-let first_available_register = [| 0; 100 |]
-
-let register_name r =
-  if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100)
-
-let rotate_registers = true
-
-(* Representation of hard registers by pseudo-registers *)
-
-let hard_int_reg =
-  let v = Array.create 20 Reg.dummy in
-  for i = 0 to 19 do v.(i) <- Reg.at_location Int (Reg i) done;
-  v
-
-let hard_float_reg =
-  let v = Array.create 31 Reg.dummy in
-  for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done;
-  v
-
-let all_phys_regs =
-  Array.append hard_int_reg hard_float_reg
-
-let phys_reg n =
-  if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100)
-
-let stack_slot slot ty =
-  Reg.at_location ty (Stack slot)
-
-(* Calling conventions *)
-
-let calling_conventions first_int last_int first_float last_float
-                        make_stack arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let int = ref first_int in
-  let float = ref first_float in
-  let ofs = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    match arg.(i).typ with
-      Int | Addr as ty ->
-        if !int <= last_int then begin
-          loc.(i) <- phys_reg !int;
-          incr int
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) ty;
-          ofs := !ofs + size_int
-        end
-    | Float ->
-        if !float <= last_float then begin
-          loc.(i) <- phys_reg !float;
-          incr float
-        end else begin
-          loc.(i) <- stack_slot (make_stack !ofs) Float;
-          ofs := !ofs + size_float
-        end
-  done;
-  (loc, Misc.align !ofs 16)         (* Keep stack 16-aligned *)
-
-let incoming ofs = Incoming ofs
-let outgoing ofs = Outgoing ofs
-let not_supported ofs = fatal_error "Proc.loc_results: cannot call"
-
-let loc_arguments arg =
-  calling_conventions 6 13 112 119 outgoing arg
-let loc_parameters arg =
-  let (loc, ofs) = calling_conventions 6 13 112 119 incoming arg in loc
-let loc_results res =
-  let (loc, ofs) = calling_conventions 0 5 100 103 not_supported res in loc
-
-(* The C calling conventions are as follows:
-   the first 8 arguments are passed either in integer regs $4...$11
-   or float regs $f12...$f19.  Each argument "consumes" both one slot
-   in the int register file and one slot in the float register file.
-   Extra arguments are passed on stack, in a 64-bits slot, right-justified
-   (i.e. at +4 from natural address). *)
-
-let loc_external_arguments arg =
-  let loc = Array.create (Array.length arg) Reg.dummy in
-  let int = ref 2 in
-  let float = ref 112 in
-  let ofs = ref 0 in
-  for i = 0 to Array.length arg - 1 do
-    if i < 8 then begin
-      loc.(i) <- phys_reg (if arg.(i).typ = Float then !float else !int);
-      incr int;
-      incr float
-    end else begin
-      begin match arg.(i).typ with
-        Float -> loc.(i) <- stack_slot (Outgoing !ofs) Float
-      | ty    -> loc.(i) <- stack_slot (Outgoing (!ofs + 4)) ty
-      end;
-      ofs := !ofs + 8
-    end
-  done;
-  (loc, Misc.align !ofs 16)
-
-let loc_external_results res =
-  let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc
-
-let loc_exn_bucket = phys_reg 0         (* $2 *)
-
-(* Registers destroyed by operations *)
-
-let destroyed_at_c_call =
-  (* $16 - $21, $f20, $f22, $f24, $f26, $f28, $f30 preserved *)
-  Array.of_list(List.map phys_reg
-    [0;1;2;3;4;5;6;7;8;9;10;11;12;13;
-     100;101;102;103;104;105;106;107;108;109;110;111;112;113;114;
-     115;116;117;118;119;121;123;125;127;129])
-
-let destroyed_at_oper = function
-    Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs
-  | Iop(Iextcall(_, false)) -> destroyed_at_c_call
-  | _ -> [||]
-
-let destroyed_at_raise = all_phys_regs
-
-(* Maximal register pressure *)
-
-let safe_register_pressure = function
-    Iextcall(_, _) -> 6
-  | _ -> 20
-let max_register_pressure = function
-    Iextcall(_, _) -> [| 6; 6 |]
-  | _ -> [| 20; 31 |]
-
-(* Layout of the stack *)
-
-let num_stack_slots = [| 0; 0 |]
-let contains_calls = ref false
-
-(* Calling the assembler *)
-
-let assemble_file infile outfile =
-  Ccomp.command (Config.asm ^ " -o " ^
-                 Filename.quote outfile ^ " " ^ Filename.quote infile)
-
-open Clflags;;
-open Config;;

diff --git a/asmcomp/mips/reload.ml b/asmcomp/mips/reload.ml
deleted file mode 100644 (file)
index 0bdd208..0000000
--- a/asmcomp/mips/reload.ml
+++ /dev/null
@@ -1,18 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Reloading for the Mips *)
-
-let fundecl f =
-  (new Reloadgen.reload_generic)#fundecl f

diff --git a/asmcomp/mips/scheduling.ml b/asmcomp/mips/scheduling.ml
deleted file mode 100644 (file)
index 062529a..0000000
--- a/asmcomp/mips/scheduling.ml
+++ /dev/null
@@ -1,20 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Schedgen (* to create a dependency *)
-
-(* No scheduling is needed for the Mips, the assembler
-   does it better than us.  *)
-
-let fundecl f = f

diff --git a/asmcomp/mips/selection.ml b/asmcomp/mips/selection.ml
deleted file mode 100644 (file)
index 4dbaa86..0000000
--- a/asmcomp/mips/selection.ml
+++ /dev/null
@@ -1,43 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Instruction selection for the Mips processor *)
-
-open Misc
-open Cmm
-open Reg
-open Arch
-open Mach
-
-class selector = object
-
-inherit Selectgen.selector_generic
-
-method is_immediate (n : int) = true
-
-method select_addressing = function
-    Cconst_symbol s ->
-      (Ibased(s, 0), Ctuple [])
-  | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
-      (Ibased(s, n), Ctuple [])
-  | Cop(Cadda, [arg; Cconst_int n]) ->
-      (Iindexed n, arg)
-  | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) ->
-      (Iindexed n, Cop(Cadda, [arg1; arg2]))
-  | arg ->
-      (Iindexed 0, arg)
-
-end
-
-let fundecl f = (new selector)#emit_fundecl f

diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml
index 8828de7c031414f266dd27693beb24de413b3ca7..c0557244ba3283aeb59984f7f89705f00867392a 100644 (file)
--- a/asmcomp/power/arch.ml
+++ b/asmcomp/power/arch.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -46,6 +46,10 @@ let size_addr = if ppc64 then 8 else 4
 let size_int = size_addr
 let size_float = 8
 
+(* Behavior of division *)
+
+let division_crashes_on_overflow = false
+
 (* Operations on addressing modes *)
 
 let identity_addressing = Iindexed 0

diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index b6496f98708181f4934b06b254f65c88d59ddc89..38586076f2f1b9497532222fad1b13da474a1ed6 100644 (file)
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -73,6 +73,9 @@ let label_prefix =
 let emit_label lbl =
   emit_string label_prefix; emit_int lbl
 
+let emit_data_label lbl =
+  emit_string label_prefix; emit_string "d"; emit_int lbl
+
 (* Section switching *)
 
 let data_space =
@@ -897,7 +900,7 @@ let emit_item = function
   | Cdefine_symbol s ->
       `{emit_symbol s}:\n`;
   | Cdefine_label lbl ->
-      `{emit_label (lbl + 100000)}:\n`
+      `{emit_data_label lbl}:\n`
   | Cint8 n ->
       `        .byte   {emit_int n}\n`
   | Cint16 n ->
@@ -915,7 +918,7 @@ let emit_item = function
   | Csymbol_address s ->
       `        {emit_string datag}     {emit_symbol s}\n`
   | Clabel_address lbl ->
-      `        {emit_string datag}     {emit_label (lbl + 100000)}\n`
+      `        {emit_string datag}     {emit_data_label lbl}\n`
   | Cstring s ->
       emit_bytes_directive "   .byte   " s
   | Cskip n ->

diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml
index ab8e5a5d5af745af3f8ac9d5768b70f69bd087a5..6eaacbbad0fc6af2a35d69b80e5b0e890b66700f 100644 (file)
--- a/asmcomp/power/proc.ml
+++ b/asmcomp/power/proc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/power/reload.ml b/asmcomp/power/reload.ml
index 3f74c3f5e5e27e9432a28dca530772b118a01c8b..ef0ab79df653042f1a2d387fb57d5097639b39ec 100644 (file)
--- a/asmcomp/power/reload.ml
+++ b/asmcomp/power/reload.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/power/scheduling.ml b/asmcomp/power/scheduling.ml
index aac37c87907bdae4b0ff7b44e6d73716dc3da951..90d08831d57600fd0b46a704e6f8f153e0c3dc68 100644 (file)
--- a/asmcomp/power/scheduling.ml
+++ b/asmcomp/power/scheduling.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml
index d87b300ccbf81b6559398fb32da3b8e5b739325e..179548af5c5dc4aba737b08aa89aa95a8be5540f 100644 (file)
--- a/asmcomp/power/selection.ml
+++ b/asmcomp/power/selection.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -52,7 +52,7 @@ inherit Selectgen.selector_generic as super
 
 method is_immediate n = (n <= 32767) && (n >= -32768)
 
-method select_addressing exp =
+method select_addressing chunk exp =
   match select_addr exp with
     (Asymbol s, d) ->
       (Ibased(s, d), Ctuple [])

diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml
new file mode 100644 (file)
index 0000000..3d89f50
--- /dev/null
+++ b/asmcomp/printclambda.ml
@@ -0,0 +1,132 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+
+open Format
+open Asttypes
+open Clambda
+open Debuginfo
+
+let rec pr_idents ppf = function
+  | [] -> ()
+  | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t
+
+let rec lam ppf = function
+  | Uvar id ->
+      Ident.print ppf id
+  | Uconst (cst,_) ->
+      Printlambda.structured_constant ppf cst
+  | Udirect_apply(f, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
+  | Ugeneric_apply(lfun, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
+  | Uclosure(clos, fv) ->
+      let idents ppf =
+        List.iter (fprintf ppf "@ %a" Ident.print)in
+      let one_fun ppf f =
+        fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])"
+          f.label f.arity idents f.params lam f.body in
+      let funs ppf =
+        List.iter (fprintf ppf "@ %a" one_fun) in
+      let lams ppf =
+        List.iter (fprintf ppf "@ %a" lam) in
+      fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
+  | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
+  | Ulet(id, arg, body) ->
+      let rec letbody ul = match ul with
+        | Ulet(id, arg, body) ->
+            fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg;
+            letbody body
+        | _ -> ul in
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg;
+      let expr = letbody body in
+      fprintf ppf ")@]@ %a)@]" lam expr
+  | Uletrec(id_arg_list, body) ->
+      let bindings ppf id_arg_list =
+        let spc = ref false in
+        List.iter
+          (fun (id, l) ->
+            if !spc then fprintf ppf "@ " else spc := true;
+            fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l)
+          id_arg_list in
+      fprintf ppf
+        "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
+  | Uprim(prim, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs
+  | Uswitch(larg, sw) ->
+      let switch ppf sw =
+        let spc = ref false in
+        for i = 0 to Array.length sw.us_index_consts - 1 do
+          let n = sw.us_index_consts.(i)
+          and l = sw.us_actions_consts.(i) in
+          if !spc then fprintf ppf "@ " else spc := true;
+          fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l;
+        done;
+        for i = 0 to Array.length sw.us_index_blocks - 1 do
+          let n = sw.us_index_blocks.(i)
+          and l = sw.us_actions_blocks.(i) in
+          if !spc then fprintf ppf "@ " else spc := true;
+          fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l;
+        done in
+      fprintf ppf
+       "@[<1>(switch %a@ @[<v 0>%a@])@]"
+        lam larg switch sw
+  | Ustaticfail (i, ls)  ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
+  | Ucatch(i, vars, lbody, lhandler) ->
+      fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
+        lam lbody i
+        (fun ppf vars -> match vars with
+          | [] -> ()
+          | _ ->
+              List.iter
+                (fun x -> fprintf ppf " %a" Ident.print x)
+                vars)
+        vars
+        lam lhandler
+  | Utrywith(lbody, param, lhandler) ->
+      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
+        lam lbody Ident.print param lam lhandler
+  | Uifthenelse(lcond, lif, lelse) ->
+      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
+  | Usequence(l1, l2) ->
+      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
+  | Uwhile(lcond, lbody) ->
+      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
+  | Ufor(param, lo, hi, dir, body) ->
+      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
+       Ident.print param lam lo
+       (match dir with Upto -> "to" | Downto -> "downto")
+       lam hi lam body
+  | Uassign(id, expr) ->
+      fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
+  | Usend (k, met, obj, largs, _) ->
+      let args ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      let kind =
+        if k = Lambda.Self then "self" else if k = Lambda.Cached then "cache" else "" in
+      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
+
+and sequence ppf ulam = match ulam with
+  | Usequence(l1, l2) ->
+      fprintf ppf "%a@ %a" sequence l1 sequence l2
+  | _ -> lam ppf ulam
+
+let clambda = lam

diff --git a/asmcomp/printclambda.mli b/asmcomp/printclambda.mli
new file mode 100644 (file)
index 0000000..ddc233a
--- /dev/null
+++ b/asmcomp/printclambda.mli
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+open Clambda
+open Format
+
+val clambda: formatter -> ulambda -> unit

diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml
index 364d9ea88af0b3b8be44b820d2dd086111961f05..ca1c0f11c3823f5375b97f9089968bac9e8bbff8 100644 (file)
--- a/asmcomp/printcmm.ml
+++ b/asmcomp/printcmm.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -176,8 +176,9 @@ let fundecl ppf f =
        if !first then first := false else fprintf ppf "@ ";
        fprintf ppf "%a: %a" Ident.print id machtype ty)
      cases in
-  fprintf ppf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@."
-         f.fun_name print_cases f.fun_args sequence f.fun_body
+  fprintf ppf "@[<1>(function%s %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@."
+         (Debuginfo.to_string f.fun_dbg) f.fun_name
+         print_cases f.fun_args sequence f.fun_body
 
 let data_item ppf = function
   | Cdefine_symbol s -> fprintf ppf "\"%s\":" s

diff --git a/asmcomp/printcmm.mli b/asmcomp/printcmm.mli
index d498ddb72b15a0b68a6dfe6ba1a46455a2172f1c..c64657653182537e6e52e1122f020bf22f00a4d9 100644 (file)
--- a/asmcomp/printcmm.mli
+++ b/asmcomp/printcmm.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml
index 3737e72c131aca2101300a34549680c8de466df2..754a4361208ee5b5fbe3e57e8d99c24c70a219aa 100644 (file)
--- a/asmcomp/printlinear.ml
+++ b/asmcomp/printlinear.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -74,4 +74,9 @@ let rec all_instr ppf i =
   | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next
 
 let fundecl ppf f =
-  fprintf ppf "@[<v 2>%s:@,%a@]" f.fun_name all_instr f.fun_body
+  let dbg =
+    if Debuginfo.is_none f.fun_dbg then
+      ""
+    else
+      " " ^ Debuginfo.to_string f.fun_dbg in
+  fprintf ppf "@[<v 2>%s:%s@,%a@]" f.fun_name dbg all_instr f.fun_body

diff --git a/asmcomp/printlinear.mli b/asmcomp/printlinear.mli
index 5e90c11c68cdd962a5b3c660c55184aaaf3c74d1..bb179c94c1d4f635eaf21a4e019a6c273a395bb6 100644 (file)
--- a/asmcomp/printlinear.mli
+++ b/asmcomp/printlinear.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index d7d538df31baef7da150583f2130a95dc87488fb..93d0a02247bdd587188688b40c761a4f06db98ea 100644 (file)
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -182,16 +182,21 @@ let rec instr ppf i =
   | Iraise ->
       fprintf ppf "raise %a" reg i.arg.(0)
   end;
-  if i.dbg != Debuginfo.none then
-    fprintf ppf " %s" (Debuginfo.to_string i.dbg);
+  if not (Debuginfo.is_none i.dbg) then
+    fprintf ppf "%s" (Debuginfo.to_string i.dbg);
   begin match i.next.desc with
     Iend -> ()
   | _ -> fprintf ppf "@,%a" instr i.next
   end
 
 let fundecl ppf f =
-  fprintf ppf "@[<v 2>%s(%a)@,%a@]"
-    f.fun_name regs f.fun_args instr f.fun_body
+  let dbg =
+    if Debuginfo.is_none f.fun_dbg then
+      ""
+    else
+      " " ^ Debuginfo.to_string f.fun_dbg in
+  fprintf ppf "@[<v 2>%s(%a)%s@,%a@]"
+    f.fun_name regs f.fun_args dbg instr f.fun_body
 
 let phase msg ppf f =
   fprintf ppf "*** %s@.%a@." msg fundecl f

diff --git a/asmcomp/printmach.mli b/asmcomp/printmach.mli
index 28328707c71a09de94562a1b19b5a93041bbd7f0..509018d54c66497fb97567eab89752ccedff9bad 100644 (file)
--- a/asmcomp/printmach.mli
+++ b/asmcomp/printmach.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/proc.mli b/asmcomp/proc.mli
index ba593592bb03336d2d19074d5315d8d176065791..7d0a5e485bc4dd1832b7aff0d1046604324256bc 100644 (file)
--- a/asmcomp/proc.mli
+++ b/asmcomp/proc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml
index f9bef49677a50019e04879c878de61ad4d9e74ef..30c0ab5ab03b9305aea6b7506aaf3b0b92060886 100644 (file)
--- a/asmcomp/reg.ml
+++ b/asmcomp/reg.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli
index b802344dedadf9baad33531aad21feb5fc0790fa..11e314f6139a750ef091c819b410803ea1d54f3f 100644 (file)
--- a/asmcomp/reg.mli
+++ b/asmcomp/reg.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/reload.mli b/asmcomp/reload.mli
index fc72446e7d2a179cecdc8477789a8387744a7ffa..ff4b1637a55d0874751c2061b1b0318bf1e622b1 100644 (file)
--- a/asmcomp/reload.mli
+++ b/asmcomp/reload.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml
index 898c65c989bd39eb414c8508e4d202bfa29e6102..9da79587a28eaae294b6c5eed85570fc3d559dd5 100644 (file)
--- a/asmcomp/reloadgen.ml
+++ b/asmcomp/reloadgen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -134,7 +134,8 @@ method fundecl f =
   redo_regalloc <- false;
   let new_body = self#reload f.fun_body in
   ({fun_name = f.fun_name; fun_args = f.fun_args;
-    fun_body = new_body; fun_fast = f.fun_fast},
+    fun_body = new_body; fun_fast = f.fun_fast;
+    fun_dbg  = f.fun_dbg},
    redo_regalloc)
 
 end

diff --git a/asmcomp/reloadgen.mli b/asmcomp/reloadgen.mli
index f0d1c78c0a34ddbc79add8f195f2d0f3bd4d87f1..9f0b2b4e1d5cda6bb130149ab9e69f7e361ceef7 100644 (file)
--- a/asmcomp/reloadgen.mli
+++ b/asmcomp/reloadgen.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml
index 00762fa36a4e62347030f3cb57a17a4900f024d4..89c031d1b79e3dc0a37f632df656c2b24681aa9c 100644 (file)
--- a/asmcomp/schedgen.ml
+++ b/asmcomp/schedgen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -349,7 +349,8 @@ method schedule_fundecl f =
     clear_code_dag();
     { fun_name = f.fun_name;
       fun_body = new_body;
-      fun_fast = f.fun_fast }
+      fun_fast = f.fun_fast;
+      fun_dbg  = f.fun_dbg }
   end else
     f
 

diff --git a/asmcomp/schedgen.mli b/asmcomp/schedgen.mli
index ab5f072b79d0c41bc5e3e117907e77e396d568c0..e2c046d22964a9b5d54ec256bb938168305e5e73 100644 (file)
--- a/asmcomp/schedgen.mli
+++ b/asmcomp/schedgen.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/scheduling.mli b/asmcomp/scheduling.mli
index dd24354ad2312231d6af91328717d81f442aa4a0..a006d1f13f8e301a2e90fa3868a352d0176e8318 100644 (file)
--- a/asmcomp/scheduling.mli
+++ b/asmcomp/scheduling.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 50f949a77f689269b2cf6906b4b963846b83894f..e2ffd34ac833e20b0e4f2b63e3a79bd8bc9beb80 100644 (file)
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -204,7 +204,7 @@ method virtual is_immediate : int -> bool
 (* Selection of addressing modes *)
 
 method virtual select_addressing :
-  Cmm.expression -> Arch.addressing_mode * Cmm.expression
+  Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression
 
 (* Default instruction selection for stores (of words) *)
 
@@ -219,10 +219,10 @@ method select_operation op args =
   | (Capply(ty, dbg), _) -> (Icall_ind, args)
   | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args)
   | (Cload chunk, [arg]) ->
-      let (addr, eloc) = self#select_addressing arg in
+      let (addr, eloc) = self#select_addressing chunk arg in
       (Iload(chunk, addr), [eloc])
   | (Cstore chunk, [arg1; arg2]) ->
-      let (addr, eloc) = self#select_addressing arg1 in
+      let (addr, eloc) = self#select_addressing chunk arg1 in
       if chunk = Word then begin
         let (op, newarg2) = self#select_store addr arg2 in
         (op, [newarg2; eloc])
@@ -366,7 +366,7 @@ method insert_move src dst =
     self#insert (Iop Imove) [|src|] [|dst|]
 
 method insert_moves src dst =
-  for i = 0 to Array.length src - 1 do
+  for i = 0 to min (Array.length src) (Array.length dst) - 1 do
     self#insert_move src.(i) dst.(i)
   done
 
@@ -389,8 +389,7 @@ method insert_op_debug op dbg rs rd =
   rd
 
 method insert_op op rs rd =
-  self#insert (Iop op) rs rd;
-  rd
+  self#insert_op_debug op Debuginfo.none rs rd
 
 (* Add the instructions for the given expression
    at the end of the self sequence *)
@@ -490,9 +489,8 @@ method emit_expr env exp =
               let (loc_arg, stack_ofs) =
                 self#emit_extcall_args env new_args in
               let rd = self#regs_for ty in
-              let loc_res = Proc.loc_external_results rd in
-              self#insert_debug (Iop(Iextcall(lbl, alloc))) dbg
-                             loc_arg loc_res;
+              let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg
+                                    loc_arg (Proc.loc_external_results rd) in
               self#insert_move_results loc_res rd stack_ofs;
               Some rd
           | Ialloc _ ->
@@ -821,12 +819,13 @@ method emit_fundecl f =
   { fun_name = f.Cmm.fun_name;
     fun_args = loc_arg;
     fun_body = self#extract;
-    fun_fast = f.Cmm.fun_fast }
+    fun_fast = f.Cmm.fun_fast;
+    fun_dbg  = f.Cmm.fun_dbg }
 
 end
 
 (* Tail call criterion (estimated).  Assumes:
-- all arguments are of type "int" (always the case for Caml function calls)
+- all arguments are of type "int" (always the case for OCaml function calls)
 - one extra argument representing the closure environment (conservative).
 *)
 

diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli
index 7c30f9f5406bd9b6a1bf225ed136902cea1dcee0..058f9e73e1a5c726fc0956006275c452ea6aa553 100644 (file)
--- a/asmcomp/selectgen.mli
+++ b/asmcomp/selectgen.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,7 +26,7 @@ class virtual selector_generic : object
     (* Must be defined to indicate whether a constant is a suitable
        immediate operand to arithmetic instructions *)
   method virtual select_addressing :
-    Cmm.expression -> Arch.addressing_mode * Cmm.expression
+    Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression
     (* Must be defined to select addressing modes *)
   method is_simple_expr: Cmm.expression -> bool
     (* Can be overridden to reflect special extcalls known to be pure *)

diff --git a/asmcomp/selection.mli b/asmcomp/selection.mli
index ab17b557d589378eac982238e34f57d94be5cf17..a78cb1daec96fc490df490bc3a760f745005c745 100644 (file)
--- a/asmcomp/selection.mli
+++ b/asmcomp/selection.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml
index 61ba35b9a5978c5778a723b2689d42ef9e7ce352..beaf33a91282d4008da73d41488ae53a9a3bb30c 100644 (file)
--- a/asmcomp/sparc/arch.ml
+++ b/asmcomp/sparc/arch.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -47,6 +47,10 @@ let size_addr = 4
 let size_int = 4
 let size_float = 8
 
+(* Behavior of division *)
+
+let division_crashes_on_overflow = false
+
 (* Operations on addressing modes *)
 
 let identity_addressing = Iindexed 0

diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp
index f44f813e53ecf69959055b1b28cfdafec90bd911..ef3fb9a8e3a6a653d97aca942431c716f4b139c0 100644 (file)
--- a/asmcomp/sparc/emit.mlp
+++ b/asmcomp/sparc/emit.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -98,6 +98,9 @@ let label_prefix =
 let emit_label lbl =
   emit_string label_prefix; emit_int lbl
 
+let emit_data_label lbl =
+  emit_string label_prefix; emit_string "d"; emit_int lbl
+
 (* Output a pseudo-register *)
 
 let emit_reg r =
@@ -714,7 +717,7 @@ let emit_item = function
   | Cdefine_symbol s ->
       `{emit_symbol s}:\n`
   | Cdefine_label lbl ->
-      `{emit_label (lbl + 100000)}:\n`
+      `{emit_data_label lbl}:\n`
   | Cint8 n ->
       `        .byte   {emit_int n}\n`
   | Cint16 n ->
@@ -730,7 +733,7 @@ let emit_item = function
   | Csymbol_address s ->
       `        .word   {emit_symbol s}\n`
   | Clabel_address lbl ->
-      `        .word   {emit_label (lbl + 100000)}\n`
+      `        .word   {emit_data_label lbl}\n`
   | Cstring s ->
       emit_string_directive "  .ascii  " s
   | Cskip n ->

diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml
index 2fd147bfc7cb53b33502c9801ffddbd18a431238..f7b204db5a337adcf46f49578216a90f3a9c5a06 100644 (file)
--- a/asmcomp/sparc/proc.ml
+++ b/asmcomp/sparc/proc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/sparc/reload.ml b/asmcomp/sparc/reload.ml
index a590ba3ffcd49a04bb48e0b31a9c06685cdb10da..6b1d8aea967ddbc9af18b93b01d657999940fe65 100644 (file)
--- a/asmcomp/sparc/reload.ml
+++ b/asmcomp/sparc/reload.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/sparc/scheduling.ml b/asmcomp/sparc/scheduling.ml
index efe9a1f4cc53ef4a28b0d29b6ebf5215b8ed8918..180af4b1933a332c3130fd91d65221c6324440d5 100644 (file)
--- a/asmcomp/sparc/scheduling.ml
+++ b/asmcomp/sparc/scheduling.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml
index 965680b65ed09b0eb5adc3971d9e9f1291576337..e82cc670aef42f686ec6c721ab117f368d5486dd 100644 (file)
--- a/asmcomp/sparc/selection.ml
+++ b/asmcomp/sparc/selection.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,7 +26,7 @@ inherit Selectgen.selector_generic as super
 
 method is_immediate n = (n <= 4095) && (n >= -4096)
 
-method select_addressing = function
+method select_addressing chunk = function
     Cconst_symbol s ->
       (Ibased(s, 0), Ctuple [])
   | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->

diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml
index 968987d480e3359bc9aafafc373610b58fed8e2d..7b055959e8a9935abbf805cf2f9c0dc7910f1b0a 100644 (file)
--- a/asmcomp/spill.ml
+++ b/asmcomp/spill.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -399,4 +399,5 @@ let fundecl f =
   { fun_name = f.fun_name;
     fun_args = f.fun_args;
     fun_body = new_body;
-    fun_fast = f.fun_fast }
+    fun_fast = f.fun_fast;
+    fun_dbg  = f.fun_dbg }

diff --git a/asmcomp/spill.mli b/asmcomp/spill.mli
index 16a8c01add699243086f13173229d0c82c63980f..4db4222272c09d40c45eae2536fe294dbfb41858 100644 (file)
--- a/asmcomp/spill.mli
+++ b/asmcomp/spill.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmcomp/split.ml b/asmcomp/split.ml
index 9e6130d2183125cb2f6d2695d1b1098655f58eb2..da5cdf1f5e8e57841565bd10c3922471c9f60f59 100644 (file)
--- a/asmcomp/split.ml
+++ b/asmcomp/split.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -207,4 +207,5 @@ let fundecl f =
   { fun_name = f.fun_name;
     fun_args = new_args;
     fun_body = new_body;
-    fun_fast = f.fun_fast }
+    fun_fast = f.fun_fast;
+    fun_dbg  = f.fun_dbg }

diff --git a/asmcomp/split.mli b/asmcomp/split.mli
index 67e0956e88cdf72838bb11e6ede12fdbcbfcaf56..baf350d50bb239d57ad8c0b130eae506bcf571e2 100644 (file)
--- a/asmcomp/split.mli
+++ b/asmcomp/split.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/asmrun/.cvsignore b/asmrun/.cvsignore
deleted file mode 100644 (file)
index b8ad3e1..0000000
--- a/asmrun/.cvsignore
+++ /dev/null
@@ -1,38 +0,0 @@
-libasmrun.a
-libasmrunp.a
-main.c
-misc.c
-freelist.c
-major_gc.c
-minor_gc.c
-memory.c
-alloc.c
-array.c
-compare.c
-ints.c
-floats.c
-str.c
-io.c
-extern.c
-intern.c
-hash.c
-sys.c
-parsing.c
-gc_ctrl.c
-terminfo.c
-md5.c
-obj.c
-lexing.c
-printexc.c
-callback.c
-weak.c
-compact.c
-finalise.c
-custom.c
-meta.c
-globroots.c
-unix.c
-dynlink.c
-signals.c
-debugger.c
-.depend.nt

diff --git a/asmrun/.depend b/asmrun/.depend
index aa0e69e1a3869c51faa7ff597a26fd9fb060abcc..1bbfddcdedb70378acd4b42938203c81e4a902b7 100644 (file)
--- a/asmrun/.depend
+++ b/asmrun/.depend
@@ -37,9 +37,10 @@ custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
   ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
   ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h
-debugger.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \
-  ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \
-  ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h
+debugger.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \
+  ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
+  ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \
+  ../byterun/misc.h
 dynlink.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \
   ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \
@@ -51,9 +52,9 @@ extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
   ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
   ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \
-  ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
-  ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \
-  ../byterun/mlvalues.h ../byterun/reverse.h
+  ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
+  ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h
 fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \
@@ -96,14 +97,14 @@ hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \
   ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \
   ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
-  ../byterun/minor_gc.h
+  ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h
 intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
-  ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
-  ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \
-  ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
-  ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \
-  ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h
+  ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \
+  ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \
+  ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
+  ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h
 ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \
@@ -174,7 +175,8 @@ natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \
   ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
   ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
   ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \
-  natdynlink.h ../byterun/osdeps.h ../byterun/fail.h
+  ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \
+  ../byterun/fail.h
 obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \
@@ -216,8 +218,9 @@ signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \
 startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
   ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \
-  ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \
-  ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \
+  ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \
+  ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
   ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
   ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \
   ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h
@@ -284,9 +287,10 @@ custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
   ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
   ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h
-debugger.d.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \
-  ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \
-  ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h
+debugger.d.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \
+  ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
+  ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \
+  ../byterun/misc.h
 dynlink.d.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \
   ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \
@@ -298,9 +302,9 @@ extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
   ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
   ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \
-  ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
-  ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \
-  ../byterun/mlvalues.h ../byterun/reverse.h
+  ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
+  ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h
 fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \
@@ -343,14 +347,14 @@ hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \
   ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \
   ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
-  ../byterun/minor_gc.h
+  ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h
 intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
-  ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
-  ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \
-  ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
-  ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \
-  ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h
+  ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \
+  ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \
+  ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
+  ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h
 ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \
@@ -421,7 +425,8 @@ natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \
   ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
   ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
   ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \
-  natdynlink.h ../byterun/osdeps.h ../byterun/fail.h
+  ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \
+  ../byterun/fail.h
 obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \
@@ -463,8 +468,9 @@ signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \
 startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
   ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \
-  ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \
-  ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \
+  ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \
+  ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
   ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
   ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \
   ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h
@@ -531,9 +537,10 @@ custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
   ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
   ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h
-debugger.p.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \
-  ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \
-  ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h
+debugger.p.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \
+  ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
+  ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \
+  ../byterun/misc.h
 dynlink.p.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \
   ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \
@@ -545,9 +552,9 @@ extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
   ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
   ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \
-  ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
-  ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \
-  ../byterun/mlvalues.h ../byterun/reverse.h
+  ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
+  ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h
 fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \
@@ -590,14 +597,14 @@ hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \
   ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \
   ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \
-  ../byterun/minor_gc.h
+  ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h
 intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
-  ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \
-  ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \
-  ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \
-  ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \
-  ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h
+  ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \
+  ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \
+  ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
+  ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h
 ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \
@@ -668,7 +675,8 @@ natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \
   ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \
   ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \
   ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \
-  natdynlink.h ../byterun/osdeps.h ../byterun/fail.h
+  ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \
+  ../byterun/fail.h
 obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \
   ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \
   ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \
@@ -710,8 +718,9 @@ signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \
 startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \
   ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \
   ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \
-  ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \
-  ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \
+  ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \
+  ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \
+  ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \
   ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \
   ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \
   ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h

diff --git a/asmrun/.ignore b/asmrun/.ignore
new file mode 100644 (file)
index 0000000..a7a9d33
--- /dev/null
+++ b/asmrun/.ignore
@@ -0,0 +1,40 @@
+*.p.c
+*.d.c
+libasmrun.a
+libasmrunp.a
+main.c
+misc.c
+freelist.c
+major_gc.c
+minor_gc.c
+memory.c
+alloc.c
+array.c
+compare.c
+ints.c
+floats.c
+str.c
+io.c
+extern.c
+intern.c
+hash.c
+sys.c
+parsing.c
+gc_ctrl.c
+terminfo.c
+md5.c
+obj.c
+lexing.c
+printexc.c
+callback.c
+weak.c
+compact.c
+finalise.c
+custom.c
+meta.c
+globroots.c
+unix.c
+dynlink.c
+signals.c
+debugger.c
+.depend.nt

diff --git a/asmrun/Makefile b/asmrun/Makefile
index 3e37ab1ea45454ef6fabde6a46353048fc42163a..2ccfa880dc6e65a9a9044f128b60433ba29c55a0 100644 (file)
--- a/asmrun/Makefile
+++ b/asmrun/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -34,13 +34,19 @@ OBJS=$(COBJS) $(ASMOBJS)
 DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS)
 POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o)
 
-all: libasmrun.a all-$(PROFILING)
+all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING)
 
 libasmrun.a: $(OBJS)
        rm -f libasmrun.a
        ar rc libasmrun.a $(OBJS)
        $(RANLIB) libasmrun.a
 
+all-noruntimed:
+.PHONY: all-noruntimed
+
+all-runtimed: libasmrund.a
+.PHONY: all-runtimed
+
 libasmrund.a: $(DOBJS)
        rm -f libasmrund.a
        ar rc libasmrund.a $(DOBJS)
@@ -55,12 +61,20 @@ libasmrunp.a: $(POBJS)
        ar rc libasmrunp.a $(POBJS)
        $(RANLIB) libasmrunp.a
 
-install: install-default install-$(PROFILING)
+install: install-default install-$(RUNTIMED) install-$(PROFILING)
 
 install-default:
        cp libasmrun.a $(LIBDIR)/libasmrun.a
        cd $(LIBDIR); $(RANLIB) libasmrun.a
 
+install-noruntimed:
+.PHONY: install-noruntimed
+
+install-runtimed:
+       cp libasmrund.a $(LIBDIR)/libasmrund.a
+       cd $(LIBDIR); $(RANLIB) libasmrund.a
+.PHONY: install-runtimed
+
 install-noprof:
        rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a
 
@@ -164,16 +178,14 @@ clean::
        $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S
 
 .c.d.o:
-       @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
-       $(CC) -c $(DFLAGS) $<
-       mv $*.o $*.d.o
-       @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
+       ln -s -f $*.c $*.d.c
+       $(CC) -c $(DFLAGS) $*.d.c
+       rm -f $*.d.c
 
 .c.p.o:
-       @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
-       $(CC) -c $(PFLAGS) $<
-       mv $*.o $*.p.o
-       @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
+       ln -s -f $*.c $*.p.c
+       $(CC) -c $(PFLAGS) $*.p.c
+       rm -f $*.p.c
 
 .s.o:
        $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s

diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt
index 75fe2614155647a5c195967998fe34c5fb1d68ad..81e289014381e30785a830492843a876b033d2c8 100644 (file)
--- a/asmrun/Makefile.nt
+++ b/asmrun/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -54,6 +54,9 @@ amd64nt.obj: amd64nt.asm
 i386.o: i386.S
        $(CC) -c -DSYS_$(SYSTEM) i386.S
 
+amd64.o: amd64.S
+       $(CC) -c -DSYS_$(SYSTEM) amd64.S
+
 install:
        cp libasmrun.$(A) $(LIBDIR)
 

diff --git a/asmrun/alpha.S b/asmrun/alpha.S
deleted file mode 100644 (file)
index c5251b7..0000000
--- a/asmrun/alpha.S
+++ /dev/null
@@ -1,440 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 1996 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, Alpha processor */
-
-/* Allocation */
-
-        .text
-        .globl  caml_alloc2
-        .globl  caml_alloc3
-        .globl  caml_allocN
-        .globl  caml_call_gc
-
-/* Note: the profiling code sets $27 to the address of the "normal" entrypoint.
-   So don't pass parameters to those routines in $27. */
-
-/* caml_alloc* : all code generator registers preserved,
-   $gp preserved, $27 not necessarily valid on entry */
-
-        .globl  caml_alloc1
-        .ent    caml_alloc1
-        .align  3
-caml_alloc1:
-        .prologue 0
-        subq    $13, 16, $13
-        cmpult  $13, $14, $25
-        bne     $25, $100
-        ret     ($26)
-$100:   ldiq    $25, 16
-        br      $110
-        .end    caml_alloc1
-
-        .globl  caml_alloc2
-        .ent    caml_alloc2
-        .align  3
-caml_alloc2:
-        .prologue 0
-        subq    $13, 24, $13
-        cmpult  $13, $14, $25
-        bne     $25, $101
-        ret     ($26)
-$101:   ldiq    $25, 24
-        br      $110
-        .end    caml_alloc2
-
-        .globl  caml_alloc3
-        .ent    caml_alloc3
-        .align  3
-caml_alloc3:
-        .prologue 0
-        subq    $13, 32, $13
-        cmpult  $13, $14, $25
-        bne     $25, $102
-        ret     ($26)
-$102:   ldiq    $25, 32
-        br      $110
-        .end    caml_alloc3
-
-        .globl  caml_allocN
-        .ent    caml_allocN
-        .align  3
-caml_allocN:
-        .prologue 0
-        subq    $13, $25, $13
-        .set    noat
-        cmpult  $13, $14, $at
-        bne     $at, $110
-        .set    at
-        ret     ($26)
-        .end    caml_allocN
-
-        .globl  caml_call_gc
-        .ent    caml_call_gc
-        .align  3
-caml_call_gc:
-        .prologue 0
-        ldiq    $25, 0
-$110:   lda     $sp, -0x200($sp)
-    /* 0x200 = 32*8 (ints) + 32*8 (floats) */
-        stq     $26, 0x1F8($sp)         /* return address */
-        stq     $gp, 0x1F0($sp)         /* caller's $gp */
-        stq     $25, 0x1E8($sp)         /* desired size */
-    /* Rebuild $gp */
-        br      $27, $103
-$103:   ldgp    $gp, 0($27)
-    /* Record lowest stack address, return address, GC regs */
-        stq     $26, caml_last_return_address
-        lda     $24, 0x200($sp)
-        stq     $24, caml_bottom_of_stack
-        lda     $24, 0x100($sp)
-        stq     $24, caml_gc_regs
-    /* Save current allocation pointer for debugging purposes */
-$113:   stq     $13, caml_young_ptr
-    /* Save trap pointer in case an exception is raised (e.g. sighandler) */
-        stq     $15, caml_exception_pointer
-    /* Save all integer regs used by the code generator in the context */
-        stq     $0, 0 * 8 ($24)
-        stq     $1, 1 * 8 ($24)
-        stq     $2, 2 * 8 ($24)
-        stq     $3, 3 * 8 ($24)
-        stq     $4, 4 * 8 ($24)
-        stq     $5, 5 * 8 ($24)
-        stq     $6, 6 * 8 ($24)
-        stq     $7, 7 * 8 ($24)
-        stq     $8, 8 * 8 ($24)
-        stq     $9, 9 * 8 ($24)
-        stq     $10, 10 * 8 ($24)
-        stq     $11, 11 * 8 ($24)
-        stq     $12, 12 * 8 ($24)
-        stq     $16, 16 * 8 ($24)
-        stq     $17, 17 * 8 ($24)
-        stq     $18, 18 * 8 ($24)
-        stq     $19, 19 * 8 ($24)
-        stq     $20, 20 * 8 ($24)
-        stq     $21, 21 * 8 ($24)
-        stq     $22, 22 * 8 ($24)
-    /* Save all float regs that are not callee-save on the stack */
-        stt     $f0, 0 * 8 ($sp)
-        stt     $f1, 1 * 8 ($sp)
-        stt     $f10, 10 * 8 ($sp)
-        stt     $f11, 11 * 8 ($sp)
-        stt     $f12, 12 * 8 ($sp)
-        stt     $f13, 13 * 8 ($sp)
-        stt     $f14, 14 * 8 ($sp)
-        stt     $f15, 15 * 8 ($sp)
-        stt     $f16, 16 * 8 ($sp)
-        stt     $f17, 17 * 8 ($sp)
-        stt     $f18, 18 * 8 ($sp)
-        stt     $f19, 19 * 8 ($sp)
-        stt     $f20, 20 * 8 ($sp)
-        stt     $f21, 21 * 8 ($sp)
-        stt     $f22, 22 * 8 ($sp)
-        stt     $f23, 23 * 8 ($sp)
-        stt     $f24, 24 * 8 ($sp)
-        stt     $f25, 25 * 8 ($sp)
-        stt     $f26, 26 * 8 ($sp)
-        stt     $f27, 27 * 8 ($sp)
-        stt     $f29, 29 * 8 ($sp)
-        stt     $f30, 30 * 8 ($sp)
-    /* Call the garbage collector */
-        jsr     caml_garbage_collection
-        ldgp    $gp, 0($26)
-    /* Restore all regs used by the code generator */
-        lda     $24, 0x100($sp)
-        ldq     $0, 0 * 8 ($24)
-        ldq     $1, 1 * 8 ($24)
-        ldq     $2, 2 * 8 ($24)
-        ldq     $3, 3 * 8 ($24)
-        ldq     $4, 4 * 8 ($24)
-        ldq     $5, 5 * 8 ($24)
-        ldq     $6, 6 * 8 ($24)
-        ldq     $7, 7 * 8 ($24)
-        ldq     $8, 8 * 8 ($24)
-        ldq     $9, 9 * 8 ($24)
-        ldq     $10, 10 * 8 ($24)
-        ldq     $11, 11 * 8 ($24)
-        ldq     $12, 12 * 8 ($24)
-        ldq     $16, 16 * 8 ($24)
-        ldq     $17, 17 * 8 ($24)
-        ldq     $18, 18 * 8 ($24)
-        ldq     $19, 19 * 8 ($24)
-        ldq     $20, 20 * 8 ($24)
-        ldq     $21, 21 * 8 ($24)
-        ldq     $22, 22 * 8 ($24)
-        ldt     $f0, 0 * 8 ($sp)
-        ldt     $f1, 1 * 8 ($sp)
-        ldt     $f10, 10 * 8 ($sp)
-        ldt     $f11, 11 * 8 ($sp)
-        ldt     $f12, 12 * 8 ($sp)
-        ldt     $f13, 13 * 8 ($sp)
-        ldt     $f14, 14 * 8 ($sp)
-        ldt     $f15, 15 * 8 ($sp)
-        ldt     $f16, 16 * 8 ($sp)
-        ldt     $f17, 17 * 8 ($sp)
-        ldt     $f18, 18 * 8 ($sp)
-        ldt     $f19, 19 * 8 ($sp)
-        ldt     $f20, 20 * 8 ($sp)
-        ldt     $f21, 21 * 8 ($sp)
-        ldt     $f22, 22 * 8 ($sp)
-        ldt     $f23, 23 * 8 ($sp)
-        ldt     $f24, 24 * 8 ($sp)
-        ldt     $f25, 25 * 8 ($sp)
-        ldt     $f26, 26 * 8 ($sp)
-        ldt     $f27, 27 * 8 ($sp)
-        ldt     $f29, 29 * 8 ($sp)
-        ldt     $f30, 30 * 8 ($sp)
-    /* Reload new allocation pointer and allocation limit */
-        ldq     $13, caml_young_ptr
-        ldq     $14, caml_young_limit
-    /* Allocate space for the block */
-        ldq     $25, 0x1E8($sp)
-        subq    $13, $25, $13
-        cmpult  $13, $14, $25   /* Check that we have enough free space */
-        bne     $25, $113       /* If not, call GC again */
-    /* Say that we are back into Caml code */
-        stq     $31, caml_last_return_address
-    /* Return to caller */
-        ldq     $26, 0x1F8($sp)
-        ldq     $gp, 0x1F0($sp)
-        lda     $sp, 0x200($sp)
-        ret     ($26)
-
-        .end    caml_call_gc
-
-/* Call a C function from Caml */
-/* Function to call is in $25 */
-
-        .globl  caml_c_call
-        .ent    caml_c_call
-        .align  3
-caml_c_call:
-        .prologue 0
-    /* Preserve return address and caller's $gp in callee-save registers */
-        mov     $26, $9
-        mov     $gp, $10
-    /* Rebuild $gp */
-        br      $27, $104
-$104:   ldgp    $gp, 0($27)
-    /* Record lowest stack address and return address */
-        lda     $11, caml_last_return_address
-        stq     $26, 0($11)
-        stq     $sp, caml_bottom_of_stack
-    /* Make the exception handler and alloc ptr available to the C code */
-        lda     $12, caml_young_ptr
-        stq     $13, 0($12)
-        lda     $14, caml_young_limit
-        stq     $15, caml_exception_pointer
-    /* Call the function */
-        mov     $25, $27
-        jsr     ($25)
-    /* Reload alloc ptr and alloc limit */
-        ldq     $13, 0($12)  /* $12 still points to caml_young_ptr */
-        ldq     $14, 0($14)  /* $14 still points to caml_young_limit */
-    /* Say that we are back into Caml code */
-        stq     $31, 0($11)  /* $11 still points to caml_last_return_address */
-    /* Restore $gp */
-        mov     $10, $gp
-    /* Return */
-        ret     ($9)
-
-        .end    caml_c_call
-
-/* Start the Caml program */
-
-        .globl  caml_start_program
-        .ent    caml_start_program
-        .align  3
-caml_start_program:
-        ldgp    $gp, 0($27)
-        lda     $25, caml_program
-
-/* Code shared with caml_callback* */
-$107:
-    /* Save return address */
-        lda     $sp, -128($sp)
-        stq     $26, 0($sp)
-    /* Save all callee-save registers */
-        stq     $9, 8($sp)
-        stq     $10, 16($sp)
-        stq     $11, 24($sp)
-        stq     $12, 32($sp)
-        stq     $13, 40($sp)
-        stq     $14, 48($sp)
-        stq     $15, 56($sp)
-        stt     $f2, 64($sp)
-        stt     $f3, 72($sp)
-        stt     $f4, 80($sp)
-        stt     $f5, 88($sp)
-        stt     $f6, 96($sp)
-        stt     $f7, 104($sp)
-        stt     $f8, 112($sp)
-        stt     $f9, 120($sp)
-    /* Set up a callback link on the stack. */
-        lda     $sp, -32($sp)
-        ldq     $0, caml_bottom_of_stack
-        stq     $0, 0($sp)
-        ldq     $1, caml_last_return_address
-        stq     $1, 8($sp)
-        ldq     $1, caml_gc_regs
-        stq     $1, 16($sp)
-    /* Set up a trap frame to catch exceptions escaping the Caml code */
-        lda     $sp, -16($sp)
-        ldq     $15, caml_exception_pointer
-        stq     $15, 0($sp)
-        lda     $0, $109
-        stq     $0, 8($sp)
-        mov     $sp, $15
-    /* Reload allocation pointers */
-        ldq     $13, caml_young_ptr
-        ldq     $14, caml_young_limit
-    /* We are back into Caml code */
-        stq     $31, caml_last_return_address
-    /* Call the Caml code */
-        mov     $25, $27
-$108:   jsr     ($25)
-    /* Reload $gp, masking off low bit in retaddr (might have been marked) */
-        bic     $26, 1, $26
-        ldgp    $gp, 4($26)
-    /* Pop the trap frame, restoring caml_exception_pointer */
-        ldq     $15, 0($sp)
-        stq     $15, caml_exception_pointer
-        lda     $sp, 16($sp)
-    /* Pop the callback link, restoring the global variables */
-$112:   ldq     $24, 0($sp)
-        stq     $24, caml_bottom_of_stack
-        ldq     $25, 8($sp)
-        stq     $25, caml_last_return_address
-        ldq     $24, 16($sp)
-        stq     $24, caml_gc_regs
-        lda     $sp, 32($sp)
-    /* Update allocation pointer */
-        stq     $13, caml_young_ptr
-    /* Reload callee-save registers */
-        ldq     $9, 8($sp)
-        ldq     $10, 16($sp)
-        ldq     $11, 24($sp)
-        ldq     $12, 32($sp)
-        ldq     $13, 40($sp)
-        ldq     $14, 48($sp)
-        ldq     $15, 56($sp)
-        ldt     $f2, 64($sp)
-        ldt     $f3, 72($sp)
-        ldt     $f4, 80($sp)
-        ldt     $f5, 88($sp)
-        ldt     $f6, 96($sp)
-        ldt     $f7, 104($sp)
-        ldt     $f8, 112($sp)
-        ldt     $f9, 120($sp)
-    /* Return to caller */
-        ldq     $26, 0($sp)
-        lda     $sp, 128($sp)
-        ret     ($26)
-
-    /* The trap handler */
-$109:   ldgp    $gp, 0($26)
-    /* Save exception pointer */
-        stq     $15, caml_exception_pointer
-    /* Encode exception bucket as an exception result */
-        or      $0, 2, $0
-    /* Return it */
-        br      $112
-
-        .end    caml_start_program
-
-/* Raise an exception from C */
-
-        .globl  caml_raise_exception
-        .ent    caml_raise_exception
-        .align  3
-caml_raise_exception:
-        ldgp    $gp, 0($27)
-        mov     $16, $0                         /* Move exn bucket */
-        ldq     $13, caml_young_ptr
-        ldq     $14, caml_young_limit
-        stq     $31, caml_last_return_address   /* We're back into Caml */
-        ldq     $sp, caml_exception_pointer
-        ldq     $15, 0($sp)
-        ldq     $26, 8($sp)
-        lda     $sp, 16($sp)
-        jmp     $25, ($26)      /* Keep retaddr in $25 to help debugging */
-        .end    caml_raise_exception
-
-/* Callback from C to Caml */
-
-        .globl  caml_callback_exn
-        .ent    caml_callback_exn
-        .align  3
-caml_callback_exn:
-    /* Initial shuffling of arguments */
-        ldgp    $gp, 0($27)
-        mov     $16, $25
-        mov     $17, $16        /* first arg */
-        mov     $25, $17        /* environment */
-        ldq     $25, 0($25)     /* code pointer */
-        br      $107
-        .end    caml_callback_exn
-
-        .globl  caml_callback2_exn
-        .ent    caml_callback2_exn
-        .align  3
-caml_callback2_exn:
-        ldgp    $gp, 0($27)
-        mov     $16, $25
-        mov     $17, $16        /* first arg */
-        mov     $18, $17        /* second arg */
-        mov     $25, $18        /* environment */
-        lda     $25, caml_apply2
-        br      $107
-        .end    caml_callback2_exn
-
-        .globl  caml_callback3_exn
-        .ent    caml_callback3_exn
-        .align  3
-caml_callback3_exn:
-        ldgp    $gp, 0($27)
-        mov     $16, $25
-        mov     $17, $16        /* first arg */
-        mov     $18, $17        /* second arg */
-        mov     $19, $18        /* third arg */
-        mov     $25, $19        /* environment */
-        lda     $25, caml_apply3
-        br      $107
-        .end    caml_callback3_exn
-
-/* Glue code to call [caml_array_bound_error] */
-
-        .globl  caml_ml_array_bound_error
-        .ent    caml_ml_array_bound_error
-        .align  3
-caml_ml_array_bound_error:
-        br      $27, $111
-$111:   ldgp    $gp, 0($27)
-        lda     $25, caml_array_bound_error
-        br      caml_c_call             /* never returns */
-        .end    caml_ml_array_bound_error
-
-#if defined(SYS_digital)
-        .rdata
-#else
-        .section .rodata
-#endif
-        .globl  caml_system__frametable
-caml_system__frametable:
-        .quad   1               /* one descriptor */
-        .quad   $108 + 4        /* return address into callback */
-        .word   -1              /* negative frame size => use callback link */
-        .word   0               /* no roots here */
-        .align  3

diff --git a/asmrun/amd64.S b/asmrun/amd64.S
index 645c2e616d307bdbc2e1bd5a1158cb5ad1eb75aa..715e796bcbe030d0218919de3b549947022c328c 100644 (file)
--- a/asmrun/amd64.S
+++ b/asmrun/amd64.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -18,8 +18,11 @@
 
 /* PIC mode support based on contribution by Paul Stravers (see PR#4795) */
 
-#ifdef SYS_macosx
+#include "../config/m.h"
 
+#if defined(SYS_macosx)
+
+#define LBL(x) L##x    
 #define G(r) _##r
 #define GREL(r) _##r@GOTPCREL
 #define GCALL(r) _##r
@@ -31,8 +34,23 @@
         .align FUNCTION_ALIGN; \
         name:
 
+#elif defined(SYS_mingw64)
+       
+#define LBL(x) .L##x   
+#define G(r) r
+#undef  GREL
+#define GCALL(r) r
+#define FUNCTION_ALIGN 4
+#define EIGHT_ALIGN 8
+#define SIXTEEN_ALIGN 16
+#define FUNCTION(name) \
+        .globl name; \
+        .align FUNCTION_ALIGN; \
+        name:
+
 #else
 
+#define LBL(x) .L##x   
 #define G(r) r
 #define GREL(r) r@GOTPCREL
 #define GCALL(r) r@PLT
@@ -47,7 +65,17 @@
 
 #endif
 
-#ifdef __PIC__
+#ifdef ASM_CFI_SUPPORTED
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#endif
+        
+#if defined(__PIC__) && !defined(SYS_mingw64)
 
 /* Position-independent operations on global variables. */
 
@@ -118,15 +146,108 @@
         leaq    8+OFFSET(%rsp), %rax ; \
        STORE_VAR(%rax,caml_bottom_of_stack)
 
+#endif
+
+/* Save and restore all callee-save registers on stack.  
+   Keep the stack 16-aligned. */
+
+#if defined(SYS_mingw64)       
+
+/* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */
+
+#define PUSH_CALLEE_SAVE_REGS \
+        pushq   %rbx; \
+        pushq   %rbp; \
+        pushq   %rsi; \
+        pushq   %rdi; \
+        pushq   %r12; \
+        pushq   %r13; \
+        pushq   %r14; \
+        pushq   %r15; \
+       subq    $(8+10*16), %rsp; \
+       movupd  %xmm6, 0*16(%rsp); \
+        movupd  %xmm7, 1*16(%rsp); \
+        movupd  %xmm8, 2*16(%rsp); \
+        movupd  %xmm9, 3*16(%rsp); \
+        movupd  %xmm10, 4*16(%rsp); \
+        movupd  %xmm11, 5*16(%rsp); \
+        movupd  %xmm12, 6*16(%rsp); \
+        movupd  %xmm13, 7*16(%rsp); \
+        movupd  %xmm14, 8*16(%rsp); \
+        movupd  %xmm15, 9*16(%rsp)
+
+#define POP_CALLEE_SAVE_REGS \
+        movupd  0*16(%rsp), %xmm6; \
+        movupd  1*16(%rsp), %xmm7; \
+        movupd  2*16(%rsp), %xmm8; \
+        movupd  3*16(%rsp), %xmm9; \
+        movupd  4*16(%rsp), %xmm10; \
+        movupd  5*16(%rsp), %xmm11; \
+        movupd  6*16(%rsp), %xmm12; \
+        movupd  7*16(%rsp), %xmm13; \
+        movupd  8*16(%rsp), %xmm14; \
+        movupd  9*16(%rsp), %xmm15; \
+        addq    $(8+10*16), %rsp; \
+        popq    %r15; \
+        popq    %r14; \
+        popq    %r13; \
+        popq    %r12; \
+        popq    %rdi; \
+        popq    %rsi; \
+        popq    %rbp; \
+        popq    %rbx
+
+#else
+
+/* Unix API: callee-save regs are rbx, rbp, r12-r15 */
+
+#define PUSH_CALLEE_SAVE_REGS \
+        pushq   %rbx; \
+        pushq   %rbp; \
+        pushq   %r12; \
+        pushq   %r13; \
+        pushq   %r14; \
+        pushq   %r15; \
+       subq    $8, %rsp
+
+#define POP_CALLEE_SAVE_REGS \
+       addq    $8, %rsp; \
+        popq    %r15; \
+        popq    %r14; \
+        popq    %r13; \
+        popq    %r12; \
+        popq    %rbp; \
+        popq    %rbx
+
+#endif 
+
+#ifdef SYS_mingw64
+   /* Calls from OCaml to C must reserve 32 bytes of extra stack space */
+#  define PREPARE_FOR_C_CALL subq $32, %rsp    
+#  define CLEANUP_AFTER_C_CALL addq $32, %rsp
+#else
+#  define PREPARE_FOR_C_CALL
+#  define CLEANUP_AFTER_C_CALL
 #endif
 
         .text
 
+        .globl  G(caml_system__code_begin)
+G(caml_system__code_begin):
+
 /* Allocation */
 
 FUNCTION(G(caml_call_gc))
+        CFI_STARTPROC
         RECORD_STACK_FRAME(0)
-.Lcaml_call_gc:
+LBL(caml_call_gc):
+#ifndef SYS_mingw64
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subq    $32768, %rsp
+        movq    %rax, 0(%rsp)
+        addq    $32768, %rsp
+#endif
     /* Build array of registers, save it into caml_gc_regs */
         pushq   %r13
         pushq   %r12
@@ -147,6 +268,7 @@ FUNCTION(G(caml_call_gc))
        STORE_VAR(%r14, caml_exception_pointer)
     /* Save floating-point registers */
         subq    $(16*8), %rsp
+        CFI_ADJUST(232)
         movsd   %xmm0, 0*8(%rsp)
         movsd   %xmm1, 1*8(%rsp)
         movsd   %xmm2, 2*8(%rsp)
@@ -164,7 +286,9 @@ FUNCTION(G(caml_call_gc))
         movsd   %xmm14, 14*8(%rsp)
         movsd   %xmm15, 15*8(%rsp)
     /* Call the garbage collector */
+       PREPARE_FOR_C_CALL
         call    GCALL(caml_garbage_collection)
+       CLEANUP_AFTER_C_CALL
     /* Restore caml_young_ptr, caml_exception_pointer */
        LOAD_VAR(caml_young_ptr, %r15)
        LOAD_VAR(caml_exception_pointer, %r14)
@@ -199,74 +323,85 @@ FUNCTION(G(caml_call_gc))
         popq    %rbp
         popq    %r12
         popq    %r13
+        CFI_ADJUST(-232)
     /* Return to caller */
         ret
+        CFI_ENDPROC
 
 FUNCTION(G(caml_alloc1))
-.Lcaml_alloc1:
+LBL(caml_alloc1):
         subq    $16, %r15
         CMP_VAR(caml_young_limit, %r15)
-        jb      .L100
+        jb      LBL(100)
         ret
-.L100:
+LBL(100):
         RECORD_STACK_FRAME(0)
        subq    $8, %rsp
-        call    .Lcaml_call_gc
+        call    LBL(caml_call_gc)
        addq    $8, %rsp
-        jmp     .Lcaml_alloc1
+        jmp     LBL(caml_alloc1)
 
 FUNCTION(G(caml_alloc2))
-.Lcaml_alloc2:
+LBL(caml_alloc2):
         subq    $24, %r15
         CMP_VAR(caml_young_limit, %r15)
-        jb      .L101
+        jb      LBL(101)
         ret
-.L101:
+LBL(101):
         RECORD_STACK_FRAME(0)
        subq    $8, %rsp
-        call    .Lcaml_call_gc
+        call    LBL(caml_call_gc)
        addq    $8, %rsp
-        jmp     .Lcaml_alloc2
+        jmp     LBL(caml_alloc2)
 
 FUNCTION(G(caml_alloc3))
-.Lcaml_alloc3:
+LBL(caml_alloc3):
         subq    $32, %r15
         CMP_VAR(caml_young_limit, %r15)
-        jb      .L102
+        jb      LBL(102)
         ret
-.L102:
+LBL(102):
         RECORD_STACK_FRAME(0)
        subq    $8, %rsp
-        call    .Lcaml_call_gc
+        call    LBL(caml_call_gc)
        addq    $8, %rsp
-        jmp     .Lcaml_alloc3
+        jmp     LBL(caml_alloc3)
 
 FUNCTION(G(caml_allocN))
-.Lcaml_allocN:
+LBL(caml_allocN):
         pushq   %rax                       /* save desired size */
         subq    %rax, %r15
         CMP_VAR(caml_young_limit, %r15)
-        jb      .L103
+        jb      LBL(103)
         addq    $8, %rsp                  /* drop desired size */
         ret
-.L103:
+LBL(103):
         RECORD_STACK_FRAME(8)
-        call    .Lcaml_call_gc
+        call    LBL(caml_call_gc)
         popq    %rax                      /* recover desired size */
-        jmp     .Lcaml_allocN
+        jmp     LBL(caml_allocN)
 
-/* Call a C function from Caml */
+/* Call a C function from OCaml */
 
 FUNCTION(G(caml_c_call))
-.Lcaml_c_call:
+LBL(caml_c_call):
     /* Record lowest stack address and return address */
         popq    %r12
         STORE_VAR(%r12, caml_last_return_address)
         STORE_VAR(%rsp, caml_bottom_of_stack)
+#ifndef SYS_mingw64
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subq    $32768, %rsp
+        movq    %rax, 0(%rsp)
+        addq    $32768, %rsp
+#endif
     /* Make the exception handler and alloc ptr available to the C code */
        STORE_VAR(%r15, caml_young_ptr)
        STORE_VAR(%r14, caml_exception_pointer)
     /* Call the function (address in %rax) */
+    /* No need to PREPARE_FOR_C_CALL since the caller already
+       reserved the stack space if needed (cf. amd64/proc.ml) */
         call    *%rax
     /* Reload alloc ptr */
        LOAD_VAR(caml_young_ptr, %r15)
@@ -274,41 +409,40 @@ FUNCTION(G(caml_c_call))
        pushq   %r12
        ret
 
-/* Start the Caml program */
+/* Start the OCaml program */
 
 FUNCTION(G(caml_start_program))
+        CFI_STARTPROC
     /* Save callee-save registers */
-        pushq   %rbx
-        pushq   %rbp
-        pushq   %r12
-        pushq   %r13
-        pushq   %r14
-        pushq   %r15
-       subq    $8, %rsp        /* stack 16-aligned */
+        PUSH_CALLEE_SAVE_REGS
+        CFI_ADJUST(56)
     /* Initial entry point is G(caml_program) */
         leaq    GCALL(caml_program)(%rip), %r12
     /* Common code for caml_start_program and caml_callback* */
-.Lcaml_start_program:
+LBL(caml_start_program):
     /* Build a callback link */
        subq    $8, %rsp        /* stack 16-aligned */
         PUSH_VAR(caml_gc_regs)
         PUSH_VAR(caml_last_return_address)
         PUSH_VAR(caml_bottom_of_stack)
+        CFI_ADJUST(32)
     /* Setup alloc ptr and exception ptr */
        LOAD_VAR(caml_young_ptr, %r15)
        LOAD_VAR(caml_exception_pointer, %r14)
     /* Build an exception handler */
-        lea     .L108(%rip), %r13
+        lea     LBL(108)(%rip), %r13
         pushq   %r13
         pushq   %r14
+        CFI_ADJUST(16)
         movq    %rsp, %r14
-    /* Call the Caml code */
+    /* Call the OCaml code */
         call    *%r12
-.L107:
+LBL(107):
     /* Pop the exception handler */
         popq    %r14
         popq    %r12    /* dummy register */
-.L109:
+        CFI_ADJUST(-16)
+LBL(109):
     /* Update alloc ptr and exception ptr */
        STORE_VAR(%r15,caml_young_ptr)
        STORE_VAR(%r14,caml_exception_pointer)
@@ -318,35 +452,45 @@ FUNCTION(G(caml_start_program))
         POP_VAR(caml_gc_regs)
        addq    $8, %rsp
     /* Restore callee-save registers. */
-       addq    $8, %rsp
-        popq    %r15
-        popq    %r14
-        popq    %r13
-        popq    %r12
-        popq    %rbp
-        popq    %rbx
+        POP_CALLEE_SAVE_REGS
     /* Return to caller. */
         ret
-.L108:
+LBL(108):
     /* Exception handler*/
     /* Mark the bucket as an exception result and return it */
         orq     $2, %rax
-        jmp     .L109
+        jmp     LBL(109)
+        CFI_ENDPROC
+
+/* Registers holding arguments of C functions. */
+
+#ifdef SYS_mingw64
+#define C_ARG_1 %rcx
+#define C_ARG_2 %rdx
+#define C_ARG_3 %r8
+#define C_ARG_4 %r9
+#else
+#define C_ARG_1 %rdi
+#define C_ARG_2 %rsi
+#define C_ARG_3 %rdx
+#define C_ARG_4 %rcx
+#endif
 
-/* Raise an exception from Caml */
+/* Raise an exception from OCaml */
 
 FUNCTION(G(caml_raise_exn))
         TESTL_VAR($1, caml_backtrace_active)
-        jne     .L110
+        jne     LBL(110)
         movq    %r14, %rsp
         popq    %r14
         ret
-.L110:
+LBL(110):
         movq    %rax, %r12            /* Save exception bucket */
-        movq    %rax, %rdi            /* arg 1: exception bucket */
-        movq    0(%rsp), %rsi         /* arg 2: pc of raise */
-        leaq    8(%rsp), %rdx         /* arg 3: sp of raise */
-        movq    %r14, %rcx            /* arg 4: sp of handler */
+        movq    %rax, C_ARG_1         /* arg 1: exception bucket */
+        movq    0(%rsp), C_ARG_2      /* arg 2: pc of raise */
+        leaq    8(%rsp), C_ARG_3      /* arg 3: sp of raise */
+        movq    %r14, C_ARG_4         /* arg 4: sp of handler */
+       PREPARE_FOR_C_CALL            /* no need to cleanup after */
         call    GCALL(caml_stash_backtrace)
         movq    %r12, %rax            /* Recover exception bucket */
         movq    %r14, %rsp
@@ -357,18 +501,19 @@ FUNCTION(G(caml_raise_exn))
 
 FUNCTION(G(caml_raise_exception))
         TESTL_VAR($1, caml_backtrace_active)
-        jne     .L111
-        movq    %rdi, %rax
+        jne     LBL(111)
+        movq    C_ARG_1, %rax
         LOAD_VAR(caml_exception_pointer, %rsp)  /* Cut stack */
         popq    %r14                  /* Recover previous exception handler */
         LOAD_VAR(caml_young_ptr, %r15) /* Reload alloc ptr */
         ret
-.L111:
-        movq    %rdi, %r12            /* Save exception bucket */
+LBL(111):
+        movq    C_ARG_1, %r12            /* Save exception bucket */
                                       /* arg 1: exception bucket */
-       LOAD_VAR(caml_last_return_address,%rsi)   /* arg 2: pc of raise */
-        LOAD_VAR(caml_bottom_of_stack,%rdx)       /* arg 3: sp of raise */
-        LOAD_VAR(caml_exception_pointer,%rcx)     /* arg 4: sp of handler */
+       LOAD_VAR(caml_last_return_address,C_ARG_2)   /* arg 2: pc of raise */
+        LOAD_VAR(caml_bottom_of_stack,C_ARG_3)       /* arg 3: sp of raise */
+        LOAD_VAR(caml_exception_pointer,C_ARG_4)     /* arg 4: sp of handler */
+       PREPARE_FOR_C_CALL            /* no need to cleanup after */
         call    GCALL(caml_stash_backtrace)
         movq    %r12, %rax            /* Recover exception bucket */
        LOAD_VAR(caml_exception_pointer,%rsp)
@@ -376,72 +521,59 @@ FUNCTION(G(caml_raise_exception))
        LOAD_VAR(caml_young_ptr,%r15)  /* Reload alloc ptr */
         ret
 
-/* Callback from C to Caml */
+/* Callback from C to OCaml */
 
 FUNCTION(G(caml_callback_exn))
     /* Save callee-save registers */
-        pushq   %rbx
-        pushq   %rbp
-        pushq   %r12
-        pushq   %r13
-        pushq   %r14
-        pushq   %r15
-       subq    $8, %rsp        /* stack 16-aligned */
+        PUSH_CALLEE_SAVE_REGS
     /* Initial loading of arguments */
-        movq    %rdi, %rbx      /* closure */
-        movq    %rsi, %rax      /* argument */
-        movq    0(%rbx), %r12   /* code pointer */
-        jmp     .Lcaml_start_program
+        movq    C_ARG_1, %rbx      /* closure */
+        movq    C_ARG_2, %rax      /* argument */
+        movq    0(%rbx), %r12      /* code pointer */
+        jmp     LBL(caml_start_program)
 
 FUNCTION(G(caml_callback2_exn))
     /* Save callee-save registers */
-        pushq   %rbx
-        pushq   %rbp
-        pushq   %r12
-        pushq   %r13
-        pushq   %r14
-        pushq   %r15
-       subq    $8, %rsp        /* stack 16-aligned */
+        PUSH_CALLEE_SAVE_REGS
     /* Initial loading of arguments */
-        /* closure stays in %rdi */
-        movq    %rsi, %rax               /* first argument */
-        movq    %rdx, %rbx               /* second argument */
+        movq    C_ARG_1, %rdi      /* closure -- no op with Unix conventions */
+        movq    C_ARG_2, %rax      /* first argument */
+        movq    C_ARG_3, %rbx      /* second argument */
         leaq    GCALL(caml_apply2)(%rip), %r12  /* code pointer */
-        jmp     .Lcaml_start_program
+        jmp     LBL(caml_start_program)
 
 FUNCTION(G(caml_callback3_exn))
     /* Save callee-save registers */
-        pushq   %rbx
-        pushq   %rbp
-        pushq   %r12
-        pushq   %r13
-        pushq   %r14
-        pushq   %r15
-       subq    $8, %rsp        /* stack 16-aligned */
+        PUSH_CALLEE_SAVE_REGS
     /* Initial loading of arguments */
-        movq    %rsi, %rax               /* first argument */
-        movq    %rdx, %rbx               /* second argument */
-        movq    %rdi, %rsi               /* closure */
-        movq    %rcx, %rdi               /* third argument */
+        movq    C_ARG_2, %rax      /* first argument */
+        movq    C_ARG_3, %rbx      /* second argument */
+        movq    C_ARG_1, %rsi      /* closure */
+        movq    C_ARG_4, %rdi      /* third argument */
         leaq    GCALL(caml_apply3)(%rip), %r12  /* code pointer */
-        jmp     .Lcaml_start_program
+        jmp     LBL(caml_start_program)
 
 FUNCTION(G(caml_ml_array_bound_error))
         leaq    GCALL(caml_array_bound_error)(%rip), %rax
-        jmp     .Lcaml_c_call
+        jmp     LBL(caml_c_call)
+
+        .globl  G(caml_system__code_end)
+G(caml_system__code_end):
 
         .data
         .globl  G(caml_system__frametable)
         .align  EIGHT_ALIGN
 G(caml_system__frametable):
         .quad   1           /* one descriptor */
-        .quad   .L107       /* return address into callback */
+        .quad   LBL(107)    /* return address into callback */
         .value  -1          /* negative frame size => use callback link */
         .value  0           /* no roots here */
         .align  EIGHT_ALIGN
 
-#ifdef SYS_macosx
+#if defined(SYS_macosx)
        .literal16
+#elif defined(SYS_mingw64)
+       .section .rdata,"dr"
 #else
        .section    .rodata.cst8,"a",@progbits
 #endif

diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm
index 4c31bc873155b0540b26123526af6d42ef01883a..7dfb31437c06ec30615441efc9eac0003e813dc0 100644 (file)
--- a/asmrun/amd64nt.asm
+++ b/asmrun/amd64nt.asm
@@ -1,15 +1,15 @@
-;*********************************************************************
-;
-;                           Objective Caml
-;
-;            Xavier Leroy, projet Gallium, INRIA Rocquencourt
-;
-;  Copyright 2006 Institut National de Recherche en Informatique et
-;  en Automatique.  All rights reserved.  This file is distributed
-;  under the terms of the GNU Library General Public License, with
-;  the special exception on linking described in file ../LICENSE.
-;
-;*********************************************************************
+;***********************************************************************
+;*                                                                     *
+;*                                OCaml                                *
+;*                                                                     *
+;*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *
+;*                                                                     *
+;*  Copyright 2006 Institut National de Recherche en Informatique et   *
+;*  en Automatique.  All rights reserved.  This file is distributed    *
+;*  under the terms of the GNU Library General Public License, with    *
+;*  the special exception on linking described in file ../LICENSE.     *
+;*                                                                     *
+;***********************************************************************
 
 ; $Id$
 
@@ -192,7 +192,7 @@ L103:
         pop     rax                      ; recover desired size
         jmp     caml_allocN
 
-; Call a C function from Caml
+; Call a C function from OCaml
 
         PUBLIC  caml_c_call
         ALIGN   16
@@ -212,7 +212,7 @@ caml_c_call:
        push    r12
        ret
 
-; Start the Caml program
+; Start the OCaml program
 
         PUBLIC  caml_start_program
         ALIGN   16
@@ -254,7 +254,7 @@ L106:
         push    r13
         push    r14
         mov     r14, rsp
-    ; Call the Caml code
+    ; Call the OCaml code
         call    r12
 L107:
     ; Pop the exception handler
@@ -297,7 +297,7 @@ L108:
         or      rax, 2
         jmp     L109
 
-; Raise an exception from Caml
+; Raise an exception from OCaml
 
         PUBLIC  caml_raise_exn
         ALIGN   16
@@ -346,7 +346,7 @@ L111:
         mov     r15, caml_young_ptr ; Reload alloc ptr
         ret
 
-; Callback from C to Caml
+; Callback from C to OCaml
 
         PUBLIC  caml_callback_exn
         ALIGN   16

diff --git a/asmrun/arm.S b/asmrun/arm.S
index 8a47d182c92444ab90432832c7292a2c451f4eb4..64829566e00dcb8c5d09434c7bc38138fba0fe9a 100644 (file)
--- a/asmrun/arm.S
+++ b/asmrun/arm.S
@@ -1,275 +1,411 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                  Benedikt Meurer, University of Siegen              */
 /*                                                                     */
-/*  Copyright 1998 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
+/*    Copyright 1998 Institut National de Recherche en Informatique    */
+/*    et en Automatique. Copyright 2012 Benedikt Meurer. All rights    */
+/*    reserved. This file is distributed under the terms of the GNU    */
+/*    Library General Public License, with the special exception on    */
+/*    linking described in file ../LICENSE.                            */
 /*                                                                     */
 /***********************************************************************/
 
 /* $Id$ */
 
 /* Asm part of the runtime system, ARM processor */
+/* Must be preprocessed by cpp */
 
-trap_ptr        .req    r11
-alloc_ptr       .req    r8
-alloc_limit     .req    r10
-
+        .syntax unified
         .text
+#if defined(SYS_linux_eabihf)
+        .arch   armv7-a
+        .fpu    vfpv3-d16
+        .thumb
+#elif defined(SYS_linux_eabi)
+        .arch   armv4t
+        .arm
+
+    /* Compatibility macros */
+        .macro  blx reg
+        mov     lr, pc
+        bx      \reg
+        .endm
+        .macro  cbz reg, lbl
+        cmp     \reg, #0
+        beq     \lbl
+        .endm
+        .macro  vpop regs
+        .endm
+        .macro  vpush regs
+        .endm
+#endif
+
+trap_ptr        .req    r8
+alloc_ptr       .req    r10
+alloc_limit     .req    r11
+
+/* Support for profiling with gprof */
+
+#if defined(PROFILING) && (defined(SYS_linux_eabihf) || defined(SYS_linux_eabi))
+#define PROFILE \
+        push    {lr}; \
+        bl      __gnu_mcount_nc
+#else
+#define PROFILE
+#endif
 
 /* Allocation functions and GC interface */
 
-        .globl caml_call_gc
+        .globl  caml_system__code_begin
+caml_system__code_begin:
+        
+        .align  2
+        .globl  caml_call_gc
+        .type caml_call_gc, %function
 caml_call_gc:
-    /* Record return address and desired size */
-    /* Can use alloc_limit as a temporary since it will be reloaded by
-       invoke_gc */
-        ldr     alloc_limit, .Lcaml_last_return_address
-        str     lr, [alloc_limit, #0]
-        ldr     alloc_limit, .Lcaml_requested_size
-        str     r12, [alloc_limit, #0]
-    /* Branch to shared GC code */
-        bl      .Linvoke_gc
-    /* Finish allocation */
-       ldr     r12, .Lcaml_requested_size
-       ldr     r12, [r12, #0]
-       sub     alloc_ptr, alloc_ptr, r12
+        PROFILE
+    /* Record return address */
+        ldr     r12, =caml_last_return_address
+        str     lr, [r12]
+.Lcaml_call_gc:
+    /* Record lowest stack address */
+        ldr     r12, =caml_bottom_of_stack
+        str     sp, [r12]
+    /* Save caller floating-point registers on the stack */
+        vpush   {d0-d7}
+    /* Save integer registers and return address on the stack */
+        push    {r0-r7,r12,lr}
+    /* Store pointer to saved integer registers in caml_gc_regs */
+        ldr     r12, =caml_gc_regs
+        str     sp, [r12]
+    /* Save current allocation pointer for debugging purposes */
+        ldr     alloc_limit, =caml_young_ptr
+        str     alloc_ptr, [alloc_limit]
+    /* Save trap pointer in case an exception is raised during GC */
+        ldr     r12, =caml_exception_pointer
+        str     trap_ptr, [r12]
+    /* Call the garbage collector */
+        bl      caml_garbage_collection
+    /* Restore integer registers and return address from the stack */
+        pop     {r0-r7,r12,lr}
+    /* Restore floating-point registers from the stack */
+        vpop    {d0-d7}
+    /* Reload new allocation pointer and limit */
+    /* alloc_limit still points to caml_young_ptr */
+        ldr     r12, =caml_young_limit
+        ldr     alloc_ptr, [alloc_limit]
+        ldr     alloc_limit, [r12]
+    /* Return to caller */
         bx      lr
+        .type   caml_call_gc, %function
+        .size   caml_call_gc, .-caml_call_gc
 
-        .globl caml_alloc1
+        .align  2
+        .globl  caml_alloc1
+        .type caml_alloc1, %function
 caml_alloc1:
-        sub     alloc_ptr, alloc_ptr, #8
+        PROFILE
+.Lcaml_alloc1:
+        sub     alloc_ptr, alloc_ptr, 8
         cmp     alloc_ptr, alloc_limit
-        movcs   pc, lr                /* Return if alloc_ptr >= alloc_limit */
-    /* Record return address */
-        ldr     r12, .Lcaml_last_return_address
-        str     lr, [r12, #0]
-    /* Invoke GC */
-        bl      .Linvoke_gc
+        bcc     1f
+        bx      lr
+1:  /* Record return address */
+        ldr     r7, =caml_last_return_address
+        str     lr, [r7]
+    /* Call GC (preserves r7) */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldr     lr, [r7]
     /* Try again */
-        b       caml_alloc1
+        b       .Lcaml_alloc1
+        .type   caml_alloc1, %function
+        .size   caml_alloc1, .-caml_alloc1
 
-        .globl caml_alloc2
+        .align  2
+        .globl  caml_alloc2
+        .type caml_alloc2, %function
 caml_alloc2:
-        sub     alloc_ptr, alloc_ptr, #12
+        PROFILE
+.Lcaml_alloc2:
+        sub     alloc_ptr, alloc_ptr, 12
         cmp     alloc_ptr, alloc_limit
-        movcs   pc, lr                /* Return if alloc_ptr >= alloc_limit */
-    /* Record return address */
-        ldr     r12, .Lcaml_last_return_address
-        str     lr, [r12, #0]
-    /* Invoke GC */
-        bl      .Linvoke_gc
+        bcc     1f
+        bx      lr
+1:  /* Record return address */
+        ldr     r7, =caml_last_return_address
+        str     lr, [r7]
+    /* Call GC (preserves r7) */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldr     lr, [r7]
     /* Try again */
-        b       caml_alloc2
+        b       .Lcaml_alloc2
+        .type   caml_alloc2, %function
+        .size   caml_alloc2, .-caml_alloc2
 
-        .globl caml_alloc3
+        .align  2
+        .globl  caml_alloc3
+        .type caml_alloc3, %function
 caml_alloc3:
-        sub     alloc_ptr, alloc_ptr, #16
+        PROFILE
+.Lcaml_alloc3:
+        sub     alloc_ptr, alloc_ptr, 16
         cmp     alloc_ptr, alloc_limit
-        movcs   pc, lr                /* Return if alloc_ptr >= alloc_limit */
-    /* Record return address */
-        ldr     r12, .Lcaml_last_return_address
-        str     lr, [r12, #0]
-    /* Invoke GC */
-        bl      .Linvoke_gc
+        bcc     1f
+        bx      lr
+1:  /* Record return address */
+        ldr     r7, =caml_last_return_address
+        str     lr, [r7]
+    /* Call GC (preserves r7) */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldr     lr, [r7]
     /* Try again */
-        b       caml_alloc3
+        b       .Lcaml_alloc3
+        .type   caml_alloc3, %function
+        .size   caml_alloc3, .-caml_alloc3
 
-        .globl caml_allocN
+        .align  2
+        .globl  caml_allocN
+        .type caml_allocN, %function
 caml_allocN:
-        sub     alloc_ptr, alloc_ptr, r12
+        PROFILE
+.Lcaml_allocN:
+        sub     alloc_ptr, alloc_ptr, r7
         cmp     alloc_ptr, alloc_limit
-        movcs   pc, lr                /* Return if alloc_ptr >= alloc_limit */
-    /* Record return address and desired size */
-    /* Can use alloc_limit as a temporary since it will be reloaded by
-       invoke_gc */
-        ldr     alloc_limit, .Lcaml_last_return_address
-        str     lr, [alloc_limit, #0]
-        ldr     alloc_limit, .Lcaml_requested_size
-        str     r12, [alloc_limit, #0]
-    /* Invoke GC */
-        bl      .Linvoke_gc
+        bcc     1f
+        bx      lr
+1:  /* Record return address */
+        ldr     r12, =caml_last_return_address
+        str     lr, [r12]
+    /* Call GC (preserves r7) */
+        bl      .Lcaml_call_gc
+    /* Restore return address */
+        ldr     r12, =caml_last_return_address
+        ldr     lr, [r12]
     /* Try again */
-       ldr     r12, .Lcaml_requested_size
-       ldr     r12, [r12, #0]
-        b       caml_allocN
-
-/* Shared code to invoke the GC */
-.Linvoke_gc:
-    /* Record lowest stack address */
-        ldr     r12, .Lcaml_bottom_of_stack
-        str     sp, [r12, #0]
-    /* Save integer registers and return address on stack */
-        stmfd   sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r12,lr}
-    /* Store pointer to saved integer registers in caml_gc_regs */
-        ldr     r12, .Lcaml_gc_regs
-        str     sp, [r12, #0]
-    /* Save current allocation pointer for debugging purposes */
-        ldr     r12, .Lcaml_young_ptr
-        str     alloc_ptr, [r12, #0]
-    /* Save trap pointer in case an exception is raised during GC */
-        ldr     r12, .Lcaml_exception_pointer
-        str     trap_ptr, [r12, #0]
-    /* Call the garbage collector */
-        bl      caml_garbage_collection
-    /* Restore the registers from the stack */
-        ldmfd   sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r12}
-    /* Reload return address */
-        ldr     r12, .Lcaml_last_return_address
-        ldr     lr, [r12, #0]
-    /* Reload new allocation pointer and allocation limit */
-        ldr     r12, .Lcaml_young_ptr
-        ldr     alloc_ptr, [r12, #0]
-        ldr     r12, .Lcaml_young_limit
-        ldr     alloc_limit, [r12, #0]
-    /* Return to caller */
-        ldr     r12, [sp], #4
-        bx      r12
+        b       .Lcaml_allocN
+        .type   caml_allocN, %function
+        .size   caml_allocN, .-caml_allocN
 
-/* Call a C function from Caml */
-/* Function to call is in r12 */
+/* Call a C function from OCaml */
+/* Function to call is in r7 */
 
-        .globl caml_c_call
+        .align  2
+        .globl  caml_c_call
+        .type caml_c_call, %function
 caml_c_call:
+        PROFILE
+    /* Record lowest stack address and return address */
+        ldr     r5, =caml_last_return_address
+        ldr     r6, =caml_bottom_of_stack
+        str     lr, [r5]
+        str     sp, [r6]
     /* Preserve return address in callee-save register r4 */
         mov     r4, lr
-    /* Record lowest stack address and return address */
-        ldr     r5, .Lcaml_last_return_address
-        ldr     r6, .Lcaml_bottom_of_stack
-        str     lr, [r5, #0]
-        str     sp, [r6, #0]
-    /* Make the exception handler and alloc ptr available to the C code */
-        ldr     r6, .Lcaml_young_ptr
-        ldr     r7, .Lcaml_exception_pointer
-        str     alloc_ptr, [r6, #0]
-        str     trap_ptr, [r7, #0]
+    /* Make the exception handler alloc ptr available to the C code */
+        ldr     r5, =caml_young_ptr
+        ldr     r6, =caml_exception_pointer
+        str     alloc_ptr, [r5]
+        str     trap_ptr, [r6]
     /* Call the function */
-        mov     lr, pc
-        bx      r12
+        blx     r7
     /* Reload alloc ptr and alloc limit */
-        ldr     r5, .Lcaml_young_limit
-        ldr     alloc_ptr, [r6, #0]    /* r6 still points to caml_young_ptr */
-        ldr     alloc_limit, [r5, #0]
+        ldr     r6, =caml_young_limit
+        ldr     alloc_ptr, [r5]         /* r5 still points to caml_young_ptr */
+        ldr     alloc_limit, [r6]
     /* Return */
         bx      r4
+        .type   caml_c_call, %function
+        .size   caml_c_call, .-caml_c_call
 
-/* Start the Caml program */
+/* Start the OCaml program */
 
-        .globl caml_start_program
+        .align  2
+        .globl  caml_start_program
+        .type caml_start_program, %function
 caml_start_program:
-        ldr     r12, .Lcaml_program
+        PROFILE
+        ldr     r12, =caml_program
 
 /* Code shared with caml_callback* */
-/* Address of Caml code to call is in r12 */
-/* Arguments to the Caml code are in r0...r3 */
+/* Address of OCaml code to call is in r12 */
+/* Arguments to the OCaml code are in r0...r3 */
 
 .Ljump_to_caml:
     /* Save return address and callee-save registers */
-        stmfd   sp!, {r4,r5,r6,r7,r8,r10,r11,lr} /* 8-alignment */
+        vpush   {d8-d15}
+        push    {r4-r8,r10,r11,lr}              /* 8-byte alignment */
     /* Setup a callback link on the stack */
-        sub     sp, sp, #4*4                    /* 8-alignment */
-        ldr     r4, .Lcaml_bottom_of_stack
-        ldr     r4, [r4, #0]
-        str     r4, [sp, #0]
-        ldr     r4, .Lcaml_last_return_address
-        ldr     r4, [r4, #0]
-        str     r4, [sp, #4]
-        ldr     r4, .Lcaml_gc_regs
-        ldr     r4, [r4, #0]
-        str     r4, [sp, #8]
-    /* Setup a trap frame to catch exceptions escaping the Caml code */
-        sub     sp, sp, #4*2
-        ldr     r4, .Lcaml_exception_pointer
-        ldr     r4, [r4, #0]
-        str     r4, [sp, #0]
-        ldr     r4, .LLtrap_handler
-        str     r4, [sp, #4]
+        sub     sp, sp, 4*4                     /* 8-byte alignment */
+        ldr     r4, =caml_bottom_of_stack
+        ldr     r5, =caml_last_return_address
+        ldr     r6, =caml_gc_regs
+        ldr     r4, [r4]
+        ldr     r5, [r5]
+        ldr     r6, [r6]
+        str     r4, [sp, 0]
+        str     r5, [sp, 4]
+        str     r6, [sp, 8]
+    /* Setup a trap frame to catch exceptions escaping the OCaml code */
+        sub     sp, sp, 2*4
+        ldr     r6, =caml_exception_pointer
+        ldr     r5, =.Ltrap_handler
+        ldr     r4, [r6]
+        str     r4, [sp, 0]
+        str     r5, [sp, 4]
         mov     trap_ptr, sp
     /* Reload allocation pointers */
-        ldr     r4, .Lcaml_young_ptr
-        ldr     alloc_ptr, [r4, #0]
-        ldr     r4, .Lcaml_young_limit
-        ldr     alloc_limit, [r4, #0]
-    /* Call the Caml code */
-        mov     lr, pc
-        bx      r12
+        ldr     r4, =caml_young_ptr
+        ldr     alloc_ptr, [r4]
+        ldr     r4, =caml_young_limit
+        ldr     alloc_limit, [r4]
+    /* Call the OCaml code */
+        blx     r12
 .Lcaml_retaddr:
     /* Pop the trap frame, restoring caml_exception_pointer */
-        ldr     r4, .Lcaml_exception_pointer
-        ldr     r5, [sp, #0]
-        str     r5, [r4, #0]
-        add     sp, sp, #2 * 4
+        ldr     r4, =caml_exception_pointer
+        ldr     r5, [sp, 0]
+        str     r5, [r4]
+        add     sp, sp, 2*4
     /* Pop the callback link, restoring the global variables */
 .Lreturn_result:
-        ldr     r4, .Lcaml_bottom_of_stack
-        ldr     r5, [sp, #0]
-        str     r5, [r4, #0]
-        ldr     r4, .Lcaml_last_return_address
-        ldr     r5, [sp, #4]
-        str     r5, [r4, #0]
-        ldr     r4, .Lcaml_gc_regs
-        ldr     r5, [sp, #8]
-        str     r5, [r4, #0]
-        add     sp, sp, #4*4
+        ldr     r4, =caml_bottom_of_stack
+        ldr     r5, [sp, 0]
+        str     r5, [r4]
+        ldr     r4, =caml_last_return_address
+        ldr     r5, [sp, 4]
+        str     r5, [r4]
+        ldr     r4, =caml_gc_regs
+        ldr     r5, [sp, 8]
+        str     r5, [r4]
+        add     sp, sp, 4*4
     /* Update allocation pointer */
-        ldr     r4, .Lcaml_young_ptr
-        str     alloc_ptr, [r4, #0]
+        ldr     r4, =caml_young_ptr
+        str     alloc_ptr, [r4]
     /* Reload callee-save registers and return */
-        ldmfd   sp!, {r4,r5,r6,r7,r8,r10,r11,lr}
-       bx      lr
+        pop     {r4-r8,r10,r11,lr}
+        vpop    {d8-d15}
+        bx      lr
+        .type   .Lcaml_retaddr, %function
+        .size   .Lcaml_retaddr, .-.Lcaml_retaddr
+        .type   caml_start_program, %function
+        .size   caml_start_program, .-caml_start_program
+
+/* The trap handler */
 
-    /* The trap handler */
+        .align  2
 .Ltrap_handler:
     /* Save exception pointer */
-        ldr     r4, .Lcaml_exception_pointer
-        str     trap_ptr, [r4, #0]
+        ldr     r12, =caml_exception_pointer
+        str     trap_ptr, [r12]
     /* Encode exception bucket as an exception result */
-        orr     r0, r0, #2
+        orr     r0, r0, 2
     /* Return it */
         b       .Lreturn_result
+        .type   .Ltrap_handler, %function
+        .size   .Ltrap_handler, .-.Ltrap_handler
+
+/* Raise an exception from OCaml */
+
+        .align  2
+        .globl  caml_raise_exn
+caml_raise_exn:
+        PROFILE
+    /* Test if backtrace is active */
+        ldr     r1, =caml_backtrace_active
+        ldr     r1, [r1]
+        cbz     r1, 1f
+    /* Preserve exception bucket in callee-save register r4 */
+        mov     r4, r0
+    /* Stash the backtrace */
+        mov     r1, lr                          /* arg2: pc of raise */
+        mov     r2, sp                          /* arg3: sp of raise */
+        mov     r3, trap_ptr                    /* arg4: sp of handler */
+        bl      caml_stash_backtrace
+    /* Restore exception bucket */
+        mov     r0, r4
+1:  /* Cut stack at current trap handler */
+        mov     sp, trap_ptr
+    /* Pop previous handler and addr of trap, and jump to it */
+        pop     {trap_ptr, pc}
+        .type   caml_raise_exn, %function
+        .size   caml_raise_exn, .-caml_raise_exn
 
 /* Raise an exception from C */
 
-        .globl caml_raise_exception
+        .align  2
+        .globl  caml_raise_exception
+        .type caml_raise_exception, %function
 caml_raise_exception:
-    /* Reload Caml allocation pointers */
-        ldr     r12, .Lcaml_young_ptr
-        ldr     alloc_ptr, [r12, #0]
-        ldr     r12, .Lcaml_young_limit
-        ldr     alloc_limit, [r12, #0]
-    /* Cut stack at current trap handler */
-        ldr     r12, .Lcaml_exception_pointer
-        ldr     sp, [r12, #0]
+        PROFILE
+    /* Reload trap ptr, alloc ptr and alloc limit */
+        ldr     trap_ptr, =caml_exception_pointer
+        ldr     alloc_ptr, =caml_young_ptr
+        ldr     alloc_limit, =caml_young_limit
+        ldr     trap_ptr, [trap_ptr]
+        ldr     alloc_ptr, [alloc_ptr]
+        ldr     alloc_limit, [alloc_limit]
+    /* Test if backtrace is active */
+        ldr     r1, =caml_backtrace_active
+        ldr     r1, [r1]
+        cbz     r1, 1f
+    /* Preserve exception bucket in callee-save register r4 */
+        mov     r4, r0
+        ldr     r1, =caml_last_return_address   /* arg2: pc of raise */
+        ldr     r1, [r1]
+        ldr     r2, =caml_bottom_of_stack       /* arg3: sp of raise */
+        ldr     r2, [r2]
+        mov     r3, trap_ptr                    /* arg4: sp of handler */
+        bl      caml_stash_backtrace
+    /* Restore exception bucket */
+        mov     r0, r4
+1:  /* Cut stack at current trap handler */
+        mov     sp, trap_ptr
     /* Pop previous handler and addr of trap, and jump to it */
-        ldmfd   sp!, {trap_ptr, pc}
+        pop     {trap_ptr, pc}
+        .type   caml_raise_exception, %function
+        .size   caml_raise_exception, .-caml_raise_exception
 
-/* Callback from C to Caml */
+/* Callback from C to OCaml */
 
-        .globl caml_callback_exn
+        .align  2
+        .globl  caml_callback_exn
+        .type caml_callback_exn, %function
 caml_callback_exn:
+        PROFILE
     /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */
         mov     r12, r0
-        mov     r0, r1            /* r0 = first arg */
-        mov     r1, r12           /* r1 = closure environment */
-        ldr     r12, [r12, #0]    /* code pointer */
+        mov     r0, r1          /* r0 = first arg */
+        mov     r1, r12         /* r1 = closure environment */
+        ldr     r12, [r12]      /* code pointer */
         b       .Ljump_to_caml
+        .type   caml_callback_exn, %function
+        .size   caml_callback_exn, .-caml_callback_exn
 
-        .globl caml_callback2_exn
+        .align  2
+        .globl  caml_callback2_exn
+        .type caml_callback2_exn, %function
 caml_callback2_exn:
+        PROFILE
     /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */
         mov     r12, r0
-        mov     r0, r1           /* r0 = first arg */
-        mov     r1, r2           /* r1 = second arg */
-        mov     r2, r12          /* r2 = closure environment */
-        ldr     r12, .Lcaml_apply2
+        mov     r0, r1          /* r0 = first arg */
+        mov     r1, r2          /* r1 = second arg */
+        mov     r2, r12         /* r2 = closure environment */
+        ldr     r12, =caml_apply2
         b       .Ljump_to_caml
+        .type   caml_callback2_exn, %function
+        .size   caml_callback2_exn, .-caml_callback2_exn
 
-        .globl caml_callback3_exn
+        .align  2
+        .globl  caml_callback3_exn
+        .type caml_callback3_exn, %function
 caml_callback3_exn:
+        PROFILE
     /* Initial shuffling of arguments */
     /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */
         mov     r12, r0
@@ -277,42 +413,36 @@ caml_callback3_exn:
         mov     r1, r2          /* r1 = second arg */
         mov     r2, r3          /* r2 = third arg */
         mov     r3, r12         /* r3 = closure environment */
-        ldr     r12, .Lcaml_apply3
+        ldr     r12, =caml_apply3
         b       .Ljump_to_caml
+        .type   caml_callback3_exn, %function
+        .size   caml_callback3_exn, .-caml_callback3_exn
 
-        .globl caml_ml_array_bound_error
+        .align  2
+        .globl  caml_ml_array_bound_error
+        .type caml_ml_array_bound_error, %function
 caml_ml_array_bound_error:
-    /* Load address of [caml_array_bound_error] in r12 */
-        ldr     r12, .Lcaml_array_bound_error
+        PROFILE
+    /* Load address of [caml_array_bound_error] in r7 */
+        ldr     r7, =caml_array_bound_error
     /* Call that function */
         b       caml_c_call
+        .type   caml_ml_array_bound_error, %function
+        .size   caml_ml_array_bound_error, .-caml_ml_array_bound_error
 
-/* Global references */
-
-.Lcaml_last_return_address:     .word caml_last_return_address
-.Lcaml_bottom_of_stack:         .word caml_bottom_of_stack
-.Lcaml_gc_regs:                 .word caml_gc_regs
-.Lcaml_young_ptr:               .word caml_young_ptr
-.Lcaml_young_limit:             .word caml_young_limit
-.Lcaml_exception_pointer:       .word caml_exception_pointer
-.Lcaml_program:                 .word caml_program
-.LLtrap_handler:                .word .Ltrap_handler
-.Lcaml_apply2:                  .word caml_apply2
-.Lcaml_apply3:                  .word caml_apply3
-.Lcaml_array_bound_error:       .word caml_array_bound_error
-.Lcaml_requested_size:          .word caml_requested_size
-
-       .data
-caml_requested_size:
-       .word   0
+        .globl  caml_system__code_end
+caml_system__code_end:
 
 /* GC roots for callback */
 
         .data
-        .globl caml_system__frametable
+        .align  2
+        .globl  caml_system__frametable
 caml_system__frametable:
         .word   1               /* one descriptor */
         .word   .Lcaml_retaddr  /* return address into callback */
         .short  -1              /* negative frame size => use callback link */
         .short  0               /* no roots */
         .align  2
+        .type   caml_system__frametable, %object
+        .size   caml_system__frametable, .-caml_system__frametable

diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c
index 0825cade53866aadf75c9d73073271f0527e83d9..7b47c0bfc946564e908e39135192c3203e971046 100644 (file)
--- a/asmrun/backtrace.c
+++ b/asmrun/backtrace.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         */
 /*                                                                     */
@@ -193,7 +193,7 @@ void caml_print_exception_backtrace(void)
   }
 }
 
-/* Convert the backtrace to a data structure usable from Caml */
+/* Convert the backtrace to a data structure usable from OCaml */
 
 CAMLprim value caml_get_exception_backtrace(value unit)
 {

diff --git a/asmrun/fail.c b/asmrun/fail.c
index a1ec0fb070e82c7fa2c9c9ee8d722abfbbfe65b9..77cf4246cb31baf953f6406aac3095dae944a6c2 100644 (file)
--- a/asmrun/fail.c
+++ b/asmrun/fail.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -41,7 +41,9 @@ extern caml_generated_constant
   caml_exn_Not_found,
   caml_exn_Match_failure,
   caml_exn_Sys_blocked_io,
-  caml_exn_Stack_overflow;
+  caml_exn_Stack_overflow,
+  caml_exn_Assert_failure,
+  caml_exn_Undefined_recursive_module;
 extern caml_generated_constant
   caml_bucket_Out_of_memory,
   caml_bucket_Stack_overflow;
@@ -205,3 +207,9 @@ void caml_array_bound_error(void)
   }
   caml_raise((value) &array_bound_error_bucket.exn);
 }
+
+int caml_is_special_exception(value exn) {
+  return exn == (value) caml_exn_Match_failure
+    || exn == (value) caml_exn_Assert_failure
+    || exn == (value) caml_exn_Undefined_recursive_module;
+}

diff --git a/asmrun/hppa.S b/asmrun/hppa.S
deleted file mode 100644 (file)
index abdd455..0000000
--- a/asmrun/hppa.S
+++ /dev/null
@@ -1,534 +0,0 @@
-;*********************************************************************
-;*                                                                   *
-;*                          Objective Caml                           *
-;*                                                                   *
-;*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        *
-;*                                                                   *
-;* Copyright 1996 Institut National de Recherche en Informatique et  *
-;* en Automatique.  All rights reserved.  This file is distributed   *
-;* under the terms of the GNU Library General Public License, with   *
-;* the special exception on linking described in file ../LICENSE.    *
-;*                                                                   *
-;*********************************************************************
-
-; $Id$
-
-; Asm part of the runtime system for the HP PA-RISC processor.
-; Must be preprocessed by cpp
-
-#ifdef SYS_hpux
-#define G(x) x
-#define CODESPACE .code
-#define CODE_ALIGN 4
-#define EXPORT_CODE(x) .export x, entry, priv_lev=3
-#define EXPORT_DATA(x) .export x, data
-#define STARTPROC .proc ! .callinfo frame=0, no_calls ! .entry
-#define ENDPROC .exit ! .procend
-#define LOADHIGH(x) addil LR%x-$global$, %r27
-#define LOW(x) RR%x-$global$
-#define LOADHIGHLABEL(x) ldil LR%x, %r1
-#define LOWLABEL(x) RR%x
-#endif
-
-#if defined(SYS_linux) || defined(SYS_gnu)
-#define G(x) x
-#define CODESPACE .text
-#define CODE_ALIGN 8
-#define EXPORT_CODE(x) .globl x
-#define EXPORT_DATA(x) .globl x
-#define STARTPROC
-#define ENDPROC
-#define LOADHIGH(x) addil LR%x-$global$, %r27
-#define LOW(x) RR%x-$global$
-#define LOADHIGHLABEL(x) ldil LR%x, %r1
-#define LOWLABEL(x) RR%x
-#endif
-
-#ifdef SYS_hpux
-       .space $PRIVATE$
-       .subspa $DATA$,quad=1,align=8,access=31
-       .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82
-       .space $TEXT$
-       .subspa $LIT$,quad=0,align=8,access=44
-       .subspa $CODE$,quad=0,align=8,access=44,code_only
-       .import $global$, data
-        .import $$dyncall, millicode
-       .import caml_garbage_collection, code
-       .import caml_program, code
-       .import caml_raise, code
-       .import caml_apply2, code
-       .import caml_apply3, code
-       .import caml_array_bound_error, code
-
-caml_young_limit             .comm 8
-caml_young_ptr               .comm 8
-caml_bottom_of_stack         .comm 8
-caml_last_return_address     .comm 8
-caml_gc_regs                 .comm 8
-caml_exception_pointer       .comm 8
-caml_required_size           .comm 8
-#endif
-
-#if defined(SYS_linux) || defined(SYS_gnu)
-       .align  8
-       .comm   G(young_limit), 4
-       .comm   G(young_ptr), 4
-       .comm   G(caml_bottom_of_stack), 4
-       .comm   G(caml_last_return_address), 4
-       .comm   G(caml_gc_regs), 4
-       .comm   G(caml_exception_pointer), 4
-       .comm   G(caml_required_size), 4
-#endif
-
-; Allocation functions
-
-        CODESPACE
-       .align  CODE_ALIGN
-        EXPORT_CODE(G(caml_allocN))
-G(caml_allocN):
-        STARTPROC
-; Required size in %r29
-        ldw     0(%r4), %r1
-        sub     %r3, %r29, %r3
-        comb,<<,n %r3, %r1, G(caml_call_gc) ; nullify if taken (forward br.)
-        bv      0(%r2)
-        nop
-        ENDPROC
-
-        EXPORT_CODE(G(caml_call_gc))
-G(caml_call_gc):
-        STARTPROC
-; Save required size (%r29)
-        LOADHIGH(G(caml_required_size))
-        stw     %r29, LOW(G(caml_required_size))(%r1)
-; Save current allocation pointer for debugging purposes
-        LOADHIGH(G(caml_young_ptr))
-        stw     %r3, LOW(G(caml_young_ptr))(%r1)
-; Record lowest stack address
-        LOADHIGH(G(caml_bottom_of_stack))
-        stw     %r30, LOW(G(caml_bottom_of_stack))(%r1)
-; Record return address
-        LOADHIGH(G(caml_last_return_address))
-        stw     %r2, LOW(G(caml_last_return_address))(%r1)
-; Save the exception handler (if e.g. a sighandler raises)
-        LOADHIGH(G(caml_exception_pointer))
-        stw     %r5, LOW(G(caml_exception_pointer))(%r1)
-; Reserve stack space
-; 0x1C0 = 4 * 32 (int regs) + 8 * 32 (float regs) + 64 (for calling C)
-        ldo     0x1C0(%r30), %r30
-; Save caml_gc_regs
-L100:   ldo     -(64 + 4*32)(%r30), %r31
-        LOADHIGH(G(caml_gc_regs))
-        stw     %r31, LOW(G(caml_gc_regs))(%r1)
-; Save all regs used by the code generator
-        copy    %r31, %r1
-        stws,ma %r6, 4(%r1)
-        stws,ma %r7, 4(%r1)
-        stws,ma %r8, 4(%r1)
-        stws,ma %r9, 4(%r1)
-        stws,ma %r10, 4(%r1)
-        stws,ma %r11, 4(%r1)
-        stws,ma %r12, 4(%r1)
-        stws,ma %r13, 4(%r1)
-        stws,ma %r14, 4(%r1)
-        stws,ma %r15, 4(%r1)
-        stws,ma %r16, 4(%r1)
-        stws,ma %r17, 4(%r1)
-        stws,ma %r18, 4(%r1)
-        stws,ma %r19, 4(%r1)
-        stws,ma %r20, 4(%r1)
-        stws,ma %r21, 4(%r1)
-        stws,ma %r22, 4(%r1)
-        stws,ma %r23, 4(%r1)
-        stws,ma %r24, 4(%r1)
-        stws,ma %r25, 4(%r1)
-        stws,ma %r26, 4(%r1)
-        stws,ma %r28, 4(%r1)
-        ldo     -0x1C0(%r30), %r1
-        fstds,ma %fr4, 8(%r1)
-        fstds,ma %fr5, 8(%r1)
-        fstds,ma %fr6, 8(%r1)
-        fstds,ma %fr7, 8(%r1)
-        fstds,ma %fr8, 8(%r1)
-        fstds,ma %fr9, 8(%r1)
-        fstds,ma %fr10, 8(%r1)
-        fstds,ma %fr11, 8(%r1)
-        fstds,ma %fr12, 8(%r1)
-        fstds,ma %fr13, 8(%r1)
-        fstds,ma %fr14, 8(%r1)
-        fstds,ma %fr15, 8(%r1)
-        fstds,ma %fr16, 8(%r1)
-        fstds,ma %fr17, 8(%r1)
-        fstds,ma %fr18, 8(%r1)
-        fstds,ma %fr19, 8(%r1)
-        fstds,ma %fr20, 8(%r1)
-        fstds,ma %fr21, 8(%r1)
-        fstds,ma %fr22, 8(%r1)
-        fstds,ma %fr23, 8(%r1)
-        fstds,ma %fr24, 8(%r1)
-        fstds,ma %fr25, 8(%r1)
-        fstds,ma %fr26, 8(%r1)
-        fstds,ma %fr27, 8(%r1)
-        fstds,ma %fr28, 8(%r1)
-        fstds,ma %fr29, 8(%r1)
-        fstds,ma %fr30, 8(%r1)
-
-; Call the garbage collector
-        bl      G(caml_garbage_collection), %r2
-        nop
-
-; Restore all regs used by the code generator
-        ldo     -(64 + 4*32)(%r30), %r1
-        ldws,ma 4(%r1), %r6
-        ldws,ma 4(%r1), %r7
-        ldws,ma 4(%r1), %r8
-        ldws,ma 4(%r1), %r9
-        ldws,ma 4(%r1), %r10
-        ldws,ma 4(%r1), %r11
-        ldws,ma 4(%r1), %r12
-        ldws,ma 4(%r1), %r13
-        ldws,ma 4(%r1), %r14
-        ldws,ma 4(%r1), %r15
-        ldws,ma 4(%r1), %r16
-        ldws,ma 4(%r1), %r17
-        ldws,ma 4(%r1), %r18
-        ldws,ma 4(%r1), %r19
-        ldws,ma 4(%r1), %r20
-        ldws,ma 4(%r1), %r21
-        ldws,ma 4(%r1), %r22
-        ldws,ma 4(%r1), %r23
-        ldws,ma 4(%r1), %r24
-        ldws,ma 4(%r1), %r25
-        ldws,ma 4(%r1), %r26
-        ldws,ma 4(%r1), %r28
-        ldo     -0x1C0(%r30), %r1
-        fldds,ma 8(%r1), %fr4
-        fldds,ma 8(%r1), %fr5
-        fldds,ma 8(%r1), %fr6
-        fldds,ma 8(%r1), %fr7
-        fldds,ma 8(%r1), %fr8
-        fldds,ma 8(%r1), %fr9
-        fldds,ma 8(%r1), %fr10
-        fldds,ma 8(%r1), %fr11
-        fldds,ma 8(%r1), %fr12
-        fldds,ma 8(%r1), %fr13
-        fldds,ma 8(%r1), %fr14
-        fldds,ma 8(%r1), %fr15
-        fldds,ma 8(%r1), %fr16
-        fldds,ma 8(%r1), %fr17
-        fldds,ma 8(%r1), %fr18
-        fldds,ma 8(%r1), %fr19
-        fldds,ma 8(%r1), %fr20
-        fldds,ma 8(%r1), %fr21
-        fldds,ma 8(%r1), %fr22
-        fldds,ma 8(%r1), %fr23
-        fldds,ma 8(%r1), %fr24
-        fldds,ma 8(%r1), %fr25
-        fldds,ma 8(%r1), %fr26
-        fldds,ma 8(%r1), %fr27
-        fldds,ma 8(%r1), %fr28
-        fldds,ma 8(%r1), %fr29
-        fldds,ma 8(%r1), %fr30
-
-; Reload the allocation pointer
-        LOADHIGH(G(caml_young_ptr))
-        ldw     LOW(G(caml_young_ptr))(%r1), %r3
-; Allocate space for block
-        LOADHIGH(G(caml_required_size))
-        ldw     LOW(G(caml_required_size))(%r1), %r29
-        ldw     0(%r4), %r1
-        sub     %r3, %r29, %r3
-        comb,<< %r3, %r1, L100
-        nop
-; Return to caller
-        LOADHIGH(G(caml_last_return_address))
-        ldw     LOW(G(caml_last_return_address))(%r1), %r2
-        bv      0(%r2)
-        ldo     -0x1C0(%r30), %r30
-        ENDPROC
-
-; Call a C function from Caml
-; Function to call is in %r22
-
-       .align  CODE_ALIGN
-#ifdef SYS_hpux
-        .export G(caml_c_call), ENTRY, ARGW0=GR, ARGW1=GR, ARGW2=GR, ARGW3=GR
-#else
-       EXPORT_CODE(G(caml_c_call))
-#endif
-G(caml_c_call):
-        STARTPROC
-; Record lowest stack address
-        LOADHIGH(G(caml_bottom_of_stack))
-        stw     %r30, LOW(G(caml_bottom_of_stack))(%r1)
-; Record return address
-        LOADHIGH(G(caml_last_return_address))
-        stw     %r2, LOW(G(caml_last_return_address))(%r1)
-; Save the exception handler
-        LOADHIGH(G(caml_exception_pointer))
-        stw     %r5, LOW(G(caml_exception_pointer))(%r1)
-; Save the allocation pointer
-        LOADHIGH(G(caml_young_ptr))
-        stw     %r3, LOW(G(caml_young_ptr))(%r1)
-; Call the C function
-#ifdef SYS_hpux
-        bl      $$dyncall, %r31
-#else
-        ble     0(4, %r22)
-#endif
-        copy    %r31, %r2                       ; in delay slot
-; Reload return address
-        LOADHIGH(G(caml_last_return_address))
-        ldw     LOW(G(caml_last_return_address))(%r1), %r2
-; Reload allocation pointer
-        LOADHIGH(G(caml_young_ptr))
-; Return to caller
-        bv      0(%r2)
-        ldw     LOW(G(caml_young_ptr))(%r1), %r3   ; in delay slot
-        ENDPROC
-
-; Start the Caml program
-
-       .align  CODE_ALIGN
-       EXPORT_CODE(G(caml_start_program))
-G(caml_start_program):
-        STARTPROC
-        LOADHIGH(G(caml_program))
-        ldo     LOW(G(caml_program))(%r1), %r22
-
-; Code shared with caml_callback*
-L102:
-; Save return address
-       stw     %r2,-20(%r30)
-        ldo    256(%r30), %r30
-; Save the callee-save registers
-        ldo     -32(%r30), %r1
-        stws,ma %r3, -4(%r1)
-        stws,ma %r4, -4(%r1)
-        stws,ma %r5, -4(%r1)
-        stws,ma %r6, -4(%r1)
-        stws,ma %r7, -4(%r1)
-        stws,ma %r8, -4(%r1)
-        stws,ma %r9, -4(%r1)
-        stws,ma %r10, -4(%r1)
-        stws,ma %r11, -4(%r1)
-        stws,ma %r12, -4(%r1)
-        stws,ma %r13, -4(%r1)
-        stws,ma %r14, -4(%r1)
-        stws,ma %r15, -4(%r1)
-        stws,ma %r16, -4(%r1)
-        stws,ma %r17, -4(%r1)
-        stws,ma %r18, -4(%r1)
-       fstds,ma %fr12, -8(%r1)
-       fstds,ma %fr13, -8(%r1)
-       fstds,ma %fr14, -8(%r1)
-       fstds,ma %fr15, -8(%r1)
-       fstds,ma %fr16, -8(%r1)
-       fstds,ma %fr17, -8(%r1)
-       fstds,ma %fr18, -8(%r1)
-       fstds,ma %fr19, -8(%r1)
-       fstds,ma %fr20, -8(%r1)
-       fstds,ma %fr21, -8(%r1)
-       fstds,ma %fr22, -8(%r1)
-       fstds,ma %fr23, -8(%r1)
-       fstds,ma %fr24, -8(%r1)
-       fstds,ma %fr25, -8(%r1)
-       fstds,ma %fr26, -8(%r1)
-       fstds,ma %fr27, -8(%r1)
-       fstds,ma %fr28, -8(%r1)
-       fstds,ma %fr29, -8(%r1)
-       fstds,ma %fr30, -8(%r1)
-       fstds,ma %fr31, -8(%r1)
-; Set up a callback link
-        ldo     16(%r30), %r30
-        LOADHIGH(G(caml_bottom_of_stack))
-        ldw     LOW(G(caml_bottom_of_stack))(%r1), %r1
-        stw     %r1, -16(%r30)
-        LOADHIGH(G(caml_last_return_address))
-        ldw     LOW(G(caml_last_return_address))(%r1), %r1
-        stw     %r1, -12(%r30)
-        LOADHIGH(G(caml_gc_regs))
-        ldw     LOW(G(caml_gc_regs))(%r1), %r1
-        stw     %r1, -8(%r30)
-; Set up a trap frame to catch exceptions escaping the Caml code
-        ldo     8(%r30), %r30
-        LOADHIGH(G(caml_exception_pointer))
-        ldw     LOW(G(caml_exception_pointer))(%r1), %r1
-        stw     %r1, -8(%r30)
-        LOADHIGHLABEL(L103)
-        ldo     LOWLABEL(L103)(%r1), %r1
-        stw     %r1, -4(%r30)
-        copy    %r30, %r5
-; Reload allocation pointers
-        LOADHIGH(G(caml_young_ptr))
-        ldw     LOW(G(caml_young_ptr))(%r1), %r3
-        LOADHIGH(G(caml_young_limit))
-        ldo     LOW(G(caml_young_limit))(%r1), %r4
-; Call the Caml code
-        ble     0(4, %r22)
-        copy    %r31, %r2
-L104:
-; Pop the trap frame
-        ldw     -8(%r30), %r31
-        LOADHIGH(G(caml_exception_pointer))
-        stw     %r31, LOW(G(caml_exception_pointer))(%r1)
-        ldo     -8(%r30), %r30
-; Pop the callback link
-L105:
-        ldw     -16(%r30), %r31
-        LOADHIGH(G(caml_bottom_of_stack))
-        stw     %r31, LOW(G(caml_bottom_of_stack))(%r1)
-        ldw     -12(%r30), %r31
-        LOADHIGH(G(caml_last_return_address))
-        stw     %r31, LOW(G(caml_last_return_address))(%r1)
-        ldw     -8(%r30), %r31
-        LOADHIGH(G(caml_gc_regs))
-        stw     %r31, LOW(G(caml_gc_regs))(%r1)
-        ldo     -16(%r30), %r30
-; Save allocation pointer
-        LOADHIGH(G(caml_young_ptr))
-        stw     %r3, LOW(G(caml_young_ptr))(%r1)
-; Move result where C function expects it
-        copy    %r26, %r28
-; Reload callee-save registers
-        ldo     -32(%r30), %r1
-        ldws,ma -4(%r1), %r3
-        ldws,ma -4(%r1), %r4
-        ldws,ma -4(%r1), %r5
-        ldws,ma -4(%r1), %r6
-        ldws,ma -4(%r1), %r7
-        ldws,ma -4(%r1), %r8
-        ldws,ma -4(%r1), %r9
-        ldws,ma -4(%r1), %r10
-        ldws,ma -4(%r1), %r11
-        ldws,ma -4(%r1), %r12
-        ldws,ma -4(%r1), %r13
-        ldws,ma -4(%r1), %r14
-        ldws,ma -4(%r1), %r15
-        ldws,ma -4(%r1), %r16
-        ldws,ma -4(%r1), %r17
-        ldws,ma -4(%r1), %r18
-       fldds,ma -8(%r1), %fr12
-       fldds,ma -8(%r1), %fr13
-       fldds,ma -8(%r1), %fr14
-       fldds,ma -8(%r1), %fr15
-       fldds,ma -8(%r1), %fr16
-       fldds,ma -8(%r1), %fr17
-       fldds,ma -8(%r1), %fr18
-       fldds,ma -8(%r1), %fr19
-       fldds,ma -8(%r1), %fr20
-       fldds,ma -8(%r1), %fr21
-       fldds,ma -8(%r1), %fr22
-       fldds,ma -8(%r1), %fr23
-       fldds,ma -8(%r1), %fr24
-       fldds,ma -8(%r1), %fr25
-       fldds,ma -8(%r1), %fr26
-       fldds,ma -8(%r1), %fr27
-       fldds,ma -8(%r1), %fr28
-       fldds,ma -8(%r1), %fr29
-       fldds,ma -8(%r1), %fr30
-       fldds,ma -8(%r1), %fr31
-; Return to C
-        ldo    -256(%r30), %r30
-       ldw     -20(%r30), %r2
-        bv      0(%r2)
-        nop
-; The trap handler
-L103:
-; Save exception pointer
-        LOADHIGH(G(caml_exception_pointer))
-        stw     %r5, LOW(G(caml_exception_pointer))(%r1)
-; Encode exception bucket as an exception result and return it
-        ldi     2, %r1
-        or      %r26, %r1, %r26
-; Return it
-        b       L105
-        nop
-
-; Re-raise the exception through caml_raise, to clean up local C roots
-        ldo     64(%r30), %r30
-        bl      G(caml_raise), %r2
-        nop
-        ENDPROC
-
-; Raise an exception from C
-
-       .align  CODE_ALIGN
-       EXPORT_CODE(G(caml_raise_exception))
-G(caml_raise_exception):
-        STARTPROC
-; Cut the stack
-        LOADHIGH(G(caml_exception_pointer))
-        ldw     LOW(G(caml_exception_pointer))(%r1), %r30
-; Reload allocation registers
-        LOADHIGH(G(caml_young_ptr))
-        ldw     LOW(G(caml_young_ptr))(%r1), %r3
-        LOADHIGH(G(caml_young_limit))
-        ldo     LOW(G(caml_young_limit))(%r1), %r4
-; Raise the exception
-        ldw     -4(%r30), %r1
-        ldw     -8(%r30), %r5
-        bv      0(%r1)
-        ldo     -8(%r30), %r30  ; in delay slot
-        ENDPROC
-
-; Callbacks C -> ML
-
-        .align CODE_ALIGN
-        EXPORT_CODE(G(caml_callback_exn))
-G(caml_callback_exn):
-        STARTPROC
-; Initial shuffling of arguments
-        copy    %r26, %r1       ; Closure
-        copy    %r25, %r26      ; Argument
-        copy    %r1, %r25
-        b       L102
-        ldw     0(%r1), %r22    ; Code to call (in delay slot)
-        ENDPROC
-
-        .align CODE_ALIGN
-        EXPORT_CODE(G(caml_callback2_exn))
-G(caml_callback2_exn):
-        STARTPROC
-        copy    %r26, %r1       ; Closure
-        copy    %r25, %r26      ; First argument
-        copy    %r24, %r25      ; Second argument
-        copy    %r1, %r24
-        LOADHIGH(G(caml_apply2))
-        b       L102
-        ldo     LOW(G(caml_apply2))(%r1), %r22
-        ENDPROC
-
-        .align CODE_ALIGN
-        EXPORT_CODE(G(caml_callback3_exn))
-G(caml_callback3_exn):
-        STARTPROC
-        copy    %r26, %r1       ; Closure
-        copy    %r25, %r26      ; First argument
-        copy    %r24, %r25      ; Second argument
-        copy    %r23, %r24      ; Third argument
-        copy    %r1, %r23
-        LOADHIGH(G(caml_apply3))
-        b       L102
-        ldo     LOW(G(caml_apply3))(%r1), %r22
-        ENDPROC
-
-        .align  CODE_ALIGN
-        EXPORT_CODE(G(caml_ml_array_bound_error))
-G(caml_ml_array_bound_error):
-        STARTPROC
-; Load address of [caml_array_bound_error] in %r22
-        ldil    LR%caml_array_bound_error, %r22
-        ldo     RR%caml_array_bound_error(%r22), %r22
-; Reserve 48 bytes of stack space and jump to caml_c_call
-        b       G(caml_c_call)
-       ldo     48(%r30), %r30  /* in delay slot */
-        ENDPROC
-
-        .data
-        EXPORT_DATA(G(caml_system__frametable))
-G(caml_system__frametable):
-        .long   1               /* one descriptor */
-        .long   L104 + 3        /* return address into callback */
-        .short  -1              /* negative frame size => use callback link */
-        .short  0               /* no roots */

diff --git a/asmrun/i386.S b/asmrun/i386.S
index 73ac46741d48f05d9b9766dc4cc29989709bee90..e9b8a93bb740ec9d301127e39137c744b424636f 100644 (file)
--- a/asmrun/i386.S
+++ b/asmrun/i386.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -16,6 +16,8 @@
 /* Asm part of the runtime system, Intel 386 processor */
 /* Must be preprocessed by cpp */
 
+#include "../config/m.h"
+
 /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _.
    Linux/BSD with a.out binaries and NextStep do. */
 
@@ -42,6 +44,16 @@
 #define FUNCTION_ALIGN 2
 #endif
 
+#ifdef ASM_CFI_SUPPORTED
+#define CFI_STARTPROC .cfi_startproc
+#define CFI_ENDPROC .cfi_endproc
+#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n
+#else
+#define CFI_STARTPROC
+#define CFI_ENDPROC
+#define CFI_ADJUST(n)
+#endif
+
 #if defined(PROFILING)
 #if defined(SYS_linux_elf) || defined(SYS_gnu)
 #define PROFILE_CAML \
@@ -81,6 +93,9 @@
 /* Allocation */
 
         .text
+        .globl  G(caml_system__code_begin)
+G(caml_system__code_begin):
+
         .globl  G(caml_call_gc)
         .globl  G(caml_alloc1)
         .globl  G(caml_alloc2)
@@ -89,14 +104,22 @@
 
         .align  FUNCTION_ALIGN
 G(caml_call_gc):
+        CFI_STARTPROC
         PROFILE_CAML
     /* Record lowest stack address and return address */
         movl    0(%esp), %eax
         movl    %eax, G(caml_last_return_address)
         leal    4(%esp), %eax
         movl    %eax, G(caml_bottom_of_stack)
-    /* Build array of registers, save it into caml_gc_regs */
 LBL(105):
+#if !defined(SYS_mingw) && !defined(SYS_cygwin)
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subl    $16384, %esp
+        movl    %eax, 0(%esp)
+        addl    $16384, %esp
+#endif
+    /* Build array of registers, save it into caml_gc_regs */
         pushl   %ebp
         pushl   %edi
         pushl   %esi
@@ -104,6 +127,7 @@ LBL(105):
         pushl   %ecx
         pushl   %ebx
         pushl   %eax
+        CFI_ADJUST(28)
         movl    %esp, G(caml_gc_regs)
         /* MacOSX note: 16-alignment of stack preserved at this point */
     /* Call the garbage collector */
@@ -116,8 +140,10 @@ LBL(105):
         popl    %esi
         popl    %edi
         popl    %ebp
+        CFI_ADJUST(-28)
     /* Return to caller */
         ret
+        CFI_ENDPROC
 
         .align  FUNCTION_ALIGN
 G(caml_alloc1):
@@ -200,7 +226,7 @@ LBL(103):
         popl    %eax                    /* recover desired size */
         jmp     G(caml_allocN)
 
-/* Call a C function from Caml */
+/* Call a C function from OCaml */
 
         .globl  G(caml_c_call)
         .align  FUNCTION_ALIGN
@@ -211,20 +237,29 @@ G(caml_c_call):
         movl    %edx, G(caml_last_return_address)
         leal    4(%esp), %edx
         movl    %edx, G(caml_bottom_of_stack)
+#if !defined(SYS_mingw) && !defined(SYS_cygwin)
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        subl    $16384, %esp
+        movl    %eax, 0(%esp)
+        addl    $16384, %esp
+#endif
     /* Call the function (address in %eax) */
         jmp     *%eax
 
-/* Start the Caml program */
+/* Start the OCaml program */
 
         .globl  G(caml_start_program)
         .align  FUNCTION_ALIGN
 G(caml_start_program):
+        CFI_STARTPROC
         PROFILE_C
     /* Save callee-save registers */
         pushl   %ebx
         pushl   %esi
         pushl   %edi
         pushl   %ebp
+        CFI_ADJUST(16)
     /* Initial entry point is caml_program */
         movl    $ G(caml_program), %esi
     /* Common code for caml_start_program and caml_callback* */
@@ -238,8 +273,9 @@ LBL(106):
         pushl   $ LBL(108)
         ALIGN_STACK(8)
         pushl   G(caml_exception_pointer)
+        CFI_ADJUST(20)
         movl    %esp, G(caml_exception_pointer)
-    /* Call the Caml code */
+    /* Call the OCaml code */
         call    *%esi
 LBL(107):
     /* Pop the exception handler */
@@ -249,6 +285,7 @@ LBL(107):
 #else
         addl   $4, %esp
 #endif
+        CFI_ADJUST(-8)
 LBL(109):
     /* Pop the callback link, restoring the global variables */
         popl    G(caml_bottom_of_stack)
@@ -266,8 +303,9 @@ LBL(108):
     /* Mark the bucket as an exception result and return it */
         orl     $2, %eax
         jmp     LBL(109)
+        CFI_ENDPROC
 
-/* Raise an exception from Caml */
+/* Raise an exception from OCaml */
 
         .globl  G(caml_raise_exn)
         .align  FUNCTION_ALIGN
@@ -322,7 +360,7 @@ LBL(111):
         UNDO_ALIGN_STACK(8)
         ret
 
-/* Callback from C to Caml */
+/* Callback from C to OCaml */
 
         .globl  G(caml_callback_exn)
         .align  FUNCTION_ALIGN
@@ -396,6 +434,9 @@ G(caml_ml_array_bound_error):
     /* Branch to [caml_array_bound_error] (never returns) */
         call    G(caml_array_bound_error)
 
+        .globl  G(caml_system__code_end)
+G(caml_system__code_end):
+
         .data
         .globl  G(caml_system__frametable)
 G(caml_system__frametable):

diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm
index 711449cfbb5bc04651252cda15b903278a4509b3..7649a8a41f87a2ad1ff56afe1abde2959583c549 100644 (file)
--- a/asmrun/i386nt.asm
+++ b/asmrun/i386nt.asm
@@ -1,15 +1,15 @@
-;*********************************************************************
-;
-;                           Objective Caml
-;
-;            Xavier Leroy, projet Cristal, INRIA Rocquencourt
-;
-;  Copyright 1996 Institut National de Recherche en Informatique et
-;  en Automatique.  All rights reserved.  This file is distributed
-;  under the terms of the GNU Library General Public License, with
-;  the special exception on linking described in file ../LICENSE.
-;
-;*********************************************************************
+;***********************************************************************
+;*                                                                     *
+;*                                OCaml                                *
+;*                                                                     *
+;*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+;*                                                                     *
+;*  Copyright 1996 Institut National de Recherche en Informatique et   *
+;*  en Automatique.  All rights reserved.  This file is distributed    *
+;*  under the terms of the GNU Library General Public License, with    *
+;*  the special exception on linking described in file ../LICENSE.     *
+;*                                                                     *
+;***********************************************************************
 
 ; $Id$
 
@@ -134,7 +134,7 @@ L103:   sub     eax, _caml_young_ptr         ; eax = - size
         pop     eax                     ; recover desired size
         jmp     _caml_allocN
 
-; Call a C function from Caml
+; Call a C function from OCaml
 
         PUBLIC  _caml_c_call
         ALIGN  4
@@ -147,7 +147,7 @@ _caml_c_call:
     ; Call the function (address in %eax)
         jmp    eax
 
-; Start the Caml program
+; Start the OCaml program
 
         PUBLIC  _caml_start_program
         ALIGN  4
@@ -171,7 +171,7 @@ L106:
         push   L108
         push   _caml_exception_pointer
         mov    _caml_exception_pointer, esp
-    ; Call the Caml code
+    ; Call the OCaml code
         call   esi
 L107:
     ; Pop the exception handler
@@ -196,7 +196,7 @@ L108:
         or      eax, 2
         jmp     L109
 
-; Raise an exception for Caml
+; Raise an exception for OCaml
 
         PUBLIC  _caml_raise_exn
         ALIGN   4
@@ -244,7 +244,7 @@ L111:
         pop     _caml_exception_pointer
         ret
 
-; Callback from C to Caml
+; Callback from C to OCaml
 
         PUBLIC  _caml_callback_exn
         ALIGN  4

diff --git a/asmrun/ia64.S b/asmrun/ia64.S
deleted file mode 100644 (file)
index d4296fa..0000000
--- a/asmrun/ia64.S
+++ /dev/null
@@ -1,523 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 1996 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the Q Public License version 1.0.               */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, IA64 processor */
-
-#undef BROKEN_POSTINCREMENT
-
-#define ADDRGLOBAL(reg,symb) \
-  add reg = @ltoff(symb), gp;; ld8 reg = [reg]
-#define LOADGLOBAL(reg,symb) \
-  add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; ld8 reg = [r3]
-#define STOREGLOBAL(reg,symb) \
-  add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; st8 [r3] = reg
-
-#define ST8OFF(a,b,d) st8 [a] = b, d
-#define LD8OFF(a,b,d) ld8 a = [b], d
-#define STFDOFF(a,b,d) stfd [a] = b, d
-#define LDFDOFF(a,b,d) ldfd a = [b], d
-#define STFSPILLOFF(a,b,d) stf.spill [a] = b, d
-#define LDFFILLOFF(a,b,d) ldf.fill a = [b], d
-
-#define SAVE2(a,b) ST8OFF(r2, a, 16); ST8OFF(r3, b, 16)
-#define SAVE4(a,b,c,d) SAVE2(a,b);; SAVE2(c,d)
-#define SAVE8(a,b,c,d,e,f,g,h) SAVE4(a,b,c,d);; SAVE4(e,f,g,h)
-
-#define LOAD2(a,b) LD8OFF(a, r2, 16); LD8OFF(b, r3, 16)
-#define LOAD4(a,b,c,d) LOAD2(a,b);; LOAD2(c,d)
-#define LOAD8(a,b,c,d,e,f,g,h) LOAD4(a,b,c,d);; LOAD4(e,f,g,h)
-
-#define FSAVE2(a,b) STFDOFF(r2, a, 16); STFDOFF(r3, b, 16)
-#define FSAVE4(a,b,c,d) FSAVE2(a,b);; FSAVE2(c,d)
-#define FSAVE8(a,b,c,d,e,f,g,h) FSAVE4(a,b,c,d);; FSAVE4(e,f,g,h)
-
-#define FLOAD2(a,b) LDFDOFF(a, r2, 16); LDFDOFF(b, r3, 16)
-#define FLOAD4(a,b,c,d) FLOAD2(a,b);; FLOAD2(c,d)
-#define FLOAD8(a,b,c,d,e,f,g,h) FLOAD4(a,b,c,d);; FLOAD4(e,f,g,h)
-
-#define FSPILL2(a,b) STFSPILLOFF(r2, a, 32); STFSPILLOFF(r3, b, 32)
-#define FSPILL4(a,b,c,d) FSPILL2(a,b);; FSPILL2(c,d)
-#define FSPILL8(a,b,c,d,e,f,g,h) FSPILL4(a,b,c,d);; FSPILL4(e,f,g,h)
-
-#define FFILL2(a,b) LDFFILLOFF(a, r2, 32); LDFFILLOFF(b, r3, 32)
-#define FFILL4(a,b,c,d) FFILL2(a,b);; FFILL2(c,d)
-#define FFILL8(a,b,c,d,e,f,g,h) FFILL4(a,b,c,d);; FFILL4(e,f,g,h)
-
-/* Allocation */
-       .text
-
-        .global caml_allocN#
-        .proc   caml_allocN#
-        .align 16
-
-/* caml_allocN: all code generator registers preserved,
-   gp preserved, r2 = requested size */
-
-caml_allocN:
-        sub     r4 = r4, r2 ;;
-        cmp.ltu p0, p6 = r4, r5
-        (p6) br.ret.sptk b0 ;;
-        /* Fall through caml_call_gc */
-        br.sptk.many    caml_call_gc#
-
-        .endp   caml_allocN#
-
-/* caml_call_gc: all code generator registers preserved,
-   gp preserved, r2 = requested size */
-
-        .global caml_call_gc#
-        .proc   caml_call_gc#
-        .align 16
-caml_call_gc:
-        /* Allocate stack frame */
-        add     sp = -(16 + 16 + 80*8 + 42*8), sp ;;
-
-        /* Save requested size and GP on stack */
-        add     r3 = 16, sp ;;
-        ST8OFF(r3, r2, 8) ;;
-        st8     [r3] = gp
-
-        /* Record lowest stack address, return address, GC regs */
-        mov     r2 = b0 ;;
-        STOREGLOBAL(r2, caml_last_return_address#)
-        add     r2 = (16 + 16 + 80*8 + 42*8), sp ;;
-        STOREGLOBAL(r2, caml_bottom_of_stack#)
-        add     r2 = (16 + 16), sp ;;
-        STOREGLOBAL(r2, caml_gc_regs#)
-
-        /* Save all integer regs used by the code generator in the context */
-.L100:  add     r3 = 8, r2 ;;
-        SAVE4(r8,r9,r10,r11) ;;
-        SAVE8(r16,r17,r18,r19,r20,r21,r22,r23) ;;
-        SAVE8(r24,r25,r26,r27,r28,r29,r30,r31) ;;
-        SAVE8(r32,r33,r34,r35,r36,r37,r38,r39) ;;
-        SAVE8(r40,r41,r42,r43,r44,r45,r46,r47) ;;
-        SAVE8(r48,r49,r50,r51,r52,r53,r54,r55) ;;
-        SAVE8(r56,r57,r58,r59,r60,r61,r62,r63) ;;
-        SAVE8(r64,r65,r66,r67,r68,r69,r70,r71) ;;
-        SAVE8(r72,r73,r74,r75,r76,r77,r78,r79) ;;
-        SAVE8(r80,r81,r82,r83,r84,r85,r86,r87) ;;
-        SAVE4(r88,r89,r90,r91) ;;
-
-        /* Save all floating-point registers not preserved by C */
-        FSAVE2(f6,f7) ;;
-        FSAVE8(f8,f9,f10,f11,f12,f13,f14,f15) ;;
-        FSAVE8(f32,f33,f34,f35,f36,f37,f38,f39) ;;
-        FSAVE8(f40,f41,f42,f43,f44,f45,f46,f47) ;;
-        FSAVE8(f48,f49,f50,f51,f52,f53,f54,f55) ;;
-        FSAVE8(f56,f57,f58,f59,f60,f61,f62,f63) ;;
-
-        /* Save current allocation pointer for debugging purposes */
-        STOREGLOBAL(r4, caml_young_ptr#)
-
-        /* Save trap pointer in case an exception is raised */
-        STOREGLOBAL(r6, caml_exception_pointer#)
-
-        /* Call the garbage collector */
-        br.call.sptk    b0 = caml_garbage_collection# ;;
-
-        /* Restore gp */
-        add     r3 = 24, sp ;;
-        ld8     gp = [r3]
-
-        /* Restore all integer regs from GC context */
-        add     r2 = (16 + 16), sp ;;
-        add     r3 = 8, r2 ;;
-        LOAD4(r8,r9,r10,r11) ;;
-        LOAD8(r16,r17,r18,r19,r20,r21,r22,r23) ;;
-        LOAD8(r24,r25,r26,r27,r28,r29,r30,r31) ;;
-        LOAD8(r32,r33,r34,r35,r36,r37,r38,r39) ;;
-        LOAD8(r40,r41,r42,r43,r44,r45,r46,r47) ;;
-        LOAD8(r48,r49,r50,r51,r52,r53,r54,r55) ;;
-        LOAD8(r56,r57,r58,r59,r60,r61,r62,r63) ;;
-        LOAD8(r64,r65,r66,r67,r68,r69,r70,r71) ;;
-        LOAD8(r72,r73,r74,r75,r76,r77,r78,r79) ;;
-        LOAD8(r80,r81,r82,r83,r84,r85,r86,r87) ;;
-        LOAD4(r88,r89,r90,r91) ;;
-
-        /* Restore all floating-point registers not preserved by C */
-        FLOAD2(f6,f7) ;;
-        FLOAD8(f8,f9,f10,f11,f12,f13,f14,f15) ;;
-        FLOAD8(f32,f33,f34,f35,f36,f37,f38,f39) ;;
-        FLOAD8(f40,f41,f42,f43,f44,f45,f46,f47) ;;
-        FLOAD8(f48,f49,f50,f51,f52,f53,f54,f55) ;;
-        FLOAD8(f56,f57,f58,f59,f60,f61,f62,f63) ;;
-
-        /* Reload new allocation pointer and allocation limit */
-        LOADGLOBAL(r4, caml_young_ptr#)
-        LOADGLOBAL(r5, caml_young_limit#)
-
-        /* Allocate space for the block */
-        add     r3 = 16, sp ;;
-        ld8     r2 = [r3] ;;
-        sub     r4 = r4, r2 ;;
-        cmp.ltu p6, p0 = r4, r5         /* enough space? */
-        (p6) br.cond.spnt .L100 ;;      /* no: call GC again */
-
-        /* Reload return address and say that we are back into Caml code */
-        ADDRGLOBAL(r3, caml_last_return_address#) ;;
-        ld8     r2 = [r3]
-        st8     [r3] = r0 ;;
-
-        /* Return to caller */
-        mov     b0 = r2
-        add     sp = (16 + 16 + 80*8 + 42*8), sp ;;
-        br.ret.sptk b0
-
-        .endp   caml_call_gc#
-
-/* Call a C function from Caml */
-/* Function to call is in r2 */
-
-        .global caml_c_call#
-        .proc   caml_c_call#
-        .align  16
-
-caml_c_call:
-        /* The Caml code that called us does not expect any
-           code-generator registers to be preserved */
-
-        /* Recover entry point from the function pointer in r2 */
-        LD8OFF(r3, r2, 8) ;;
-        mov     b6 = r3
-
-        /* Preserve gp in r7 */
-        mov     r7 = gp
-
-        /* Record lowest stack address and return address */
-       mov     r14 = b0
-        STOREGLOBAL(sp, caml_bottom_of_stack#) ;;
-        STOREGLOBAL(r14, caml_last_return_address#)
-
-        /* Make the exception handler and alloc ptr available to the C code */
-        STOREGLOBAL(r4, caml_young_ptr#)
-        STOREGLOBAL(r6, caml_exception_pointer#)
-
-        /* Recover gp from the function pointer in r2 */
-        ld8     gp = [r2]
-
-        /* Call the function */
-        br.call.sptk    b0 = b6 ;;
-
-        /* Restore gp */
-        mov     gp = r7 ;;
-
-        /* Reload alloc ptr and alloc limit */
-        LOADGLOBAL(r4, caml_young_ptr#)
-        LOADGLOBAL(r5, caml_young_limit#)
-
-        /* Reload return address and say that we are back into Caml code */
-        ADDRGLOBAL(r3, caml_last_return_address#) ;;
-        ld8     r2 = [r3]
-        st8     [r3] = r0 ;;
-
-        /* Return to caller */
-        mov     b0 = r2 ;;
-        br.ret.sptk b0
-
-        .endp   caml_c_call#
-
-/* Start the Caml program */
-
-        .global caml_start_program#
-        .proc   caml_start_program#
-        .align  16
-
-caml_start_program:
-        ADDRGLOBAL(r2, caml_program#) ;;
-        mov     b6 = r2
-
-        /* Code shared with caml_callback* */
-.L103:
-        /* Allocate 64 "out" registers (for the Caml code) and no locals */
-        alloc  r3 = ar.pfs, 0, 0, 64, 0
-        add     sp = -(56 * 8), sp ;;
-
-        /* Save all callee-save registers on stack */
-        add     r2 = 16, sp ;;
-       ST8OFF(r2, r3, 8)       /* 0 : ar.pfs */
-        mov     r3 = b0 ;;
-        ST8OFF(r2, r3, 8) ;;    /* 1 : return address */
-        ST8OFF(r2, gp, 8)       /* 2 : gp */
-        mov     r3 = pr ;;
-        ST8OFF(r2, r3, 8)       /* 3 : predicates */
-        mov     r3 = ar.fpsr ;;
-        ST8OFF(r2, r3, 8)       /* 4 : ar.fpsr */
-        mov     r3 = ar.unat ;;
-        ST8OFF(r2, r3, 8)       /* 5 : ar.unat */
-        mov     r3 = ar.lc ;;
-        ST8OFF(r2, r3, 8)       /* 6 : ar.lc */
-        mov     r3 = b1 ;;
-        ST8OFF(r2, r3, 8)       /* 7 - 11 : b1 - b5 */
-        mov     r3 = b2 ;;
-        ST8OFF(r2, r3, 8)
-        mov     r3 = b3 ;;
-        ST8OFF(r2, r3, 8)
-        mov     r3 = b4 ;;
-        ST8OFF(r2, r3, 8)
-        mov     r3 = b5 ;;
-        ST8OFF(r2, r3, 8) ;;
-
-        add     r3 = 8, r2 ;;
-        SAVE4(r4,r5,r6,r7) ;;   /* 12 - 15 : r4 - r7 */
-
-        add     r3 = 16, r2 ;;  /* 16 - 55 : f2 - f5, f16 - f31 */
-        FSPILL4(f2,f3,f4,f5) ;;
-        FSPILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;;
-        FSPILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;;
-
-        /* Set up a callback link on the stack.  In addition to
-           the normal callback link contents (saved values of
-           caml_bottom_of_stack, caml_last_return_address and
-           caml_gc_regs), we also save there caml_saved_bsp
-           and caml_saved_rnat */
-        add     sp = -48, sp
-        LOADGLOBAL(r3, caml_bottom_of_stack#)
-        add     r2 = 16, sp ;;
-        ST8OFF(r2, r3, 8)
-        LOADGLOBAL(r3, caml_last_return_address#) ;;
-        ST8OFF(r2, r3, 8)
-        LOADGLOBAL(r3, caml_gc_regs#) ;;
-        ST8OFF(r2, r3, 8)
-        LOADGLOBAL(r3, caml_saved_bsp#) ;;
-        ST8OFF(r2, r3, 8)
-        LOADGLOBAL(r3, caml_saved_rnat#) ;;
-        ST8OFF(r2, r3, 8)
-
-        /* Set up a trap frame to catch exceptions escaping the Caml code */
-        mov     r6 = sp
-        add     sp = -16, sp ;;
-        LOADGLOBAL(r3, caml_exception_pointer#)
-        add     r2 = 16, sp ;;
-        ST8OFF(r2, r3, 8)
-.L110: mov     r3 = ip ;;
-       add     r3 = .L101 - .L110, r3 ;;
-        ST8OFF(r2, r3, 8) ;;
-
-        /* Save ar.bsp, flush register window, and save ar.rnat */
-        mov     r2 = ar.bsp ;;
-        STOREGLOBAL(r2, caml_saved_bsp#) ;;
-        mov     r14 = ar.rsc ;;
-        and     r2 = ~0x3, r14;;        /* set rsc.mode = 0 */
-       mov     ar.rsc = r2 ;;          /* RSE is in enforced lazy mode */
-        flushrs ;;                      /* must be first instr in group */
-        mov     r2 = ar.rnat ;;
-        STOREGLOBAL(r2, caml_saved_rnat#)
-       mov     ar.rsc = r14            /* restore original RSE mode */
-
-        /* Reload allocation pointers */
-        LOADGLOBAL(r4, caml_young_ptr#)
-        LOADGLOBAL(r5, caml_young_limit#)
-
-        /* We are back into Caml code */
-        STOREGLOBAL(r0, caml_last_return_address#)
-
-        /* Call the Caml code */
-        br.call.sptk b0 = b6 ;;
-.L102:
-
-        /* Pop the trap frame, restoring caml_exception_pointer */
-        add     sp = 16, sp ;;
-        ld8     r2 = [sp] ;;
-        STOREGLOBAL(r2, caml_exception_pointer#)
-
-.L104:
-        /* Pop the callback link, restoring the global variables */
-        add     r14 = 16, sp ;;
-        LD8OFF(r2, r14, 8) ;;
-        STOREGLOBAL(r2, caml_bottom_of_stack#)
-        LD8OFF(r2, r14, 8) ;;
-        STOREGLOBAL(r2, caml_last_return_address#)
-        LD8OFF(r2, r14, 8) ;;
-        STOREGLOBAL(r2, caml_gc_regs#)
-        LD8OFF(r2, r14, 8) ;;
-        STOREGLOBAL(r2, caml_saved_bsp#)
-        LD8OFF(r2, r14, 8) ;;
-        STOREGLOBAL(r2, caml_saved_rnat#)
-        add     sp = 48, sp
-
-        /* Update allocation pointer */
-        STOREGLOBAL(r4, caml_young_ptr#)
-
-        /* Restore all callee-save registers from stack */
-        add     r2 = 16, sp ;;
-       LD8OFF(r3, r2, 8) ;;    /* 0 : ar.pfs */
-        mov     ar.pfs = r3
-        LD8OFF(r3, r2, 8) ;;    /* 1 : return address */
-        mov     b0 = r3
-        LD8OFF(gp, r2, 8) ;;    /* 2 : gp */
-        LD8OFF(r3, r2, 8) ;;    /* 3 : predicates */
-        mov     pr = r3, -1
-        LD8OFF(r3, r2, 8) ;;    /* 4 : ar.fpsr */
-        mov     ar.fpsr = r3
-        LD8OFF(r3, r2, 8) ;;    /* 5 : ar.unat */
-        mov     ar.unat = r3
-        LD8OFF(r3, r2, 8) ;;    /* 6 : ar.lc */
-        mov     ar.lc = r3
-        LD8OFF(r3, r2, 8) ;;    /* 7 - 11 : b1 - b5 */
-        mov     b1 = r3
-        LD8OFF(r3, r2, 8) ;;
-        mov     b2 = r3
-        LD8OFF(r3, r2, 8) ;;
-        mov     b3 = r3
-        LD8OFF(r3, r2, 8) ;;
-        mov     b4 = r3
-        LD8OFF(r3, r2, 8) ;;
-        mov     b5 = r3
-
-        add     r3 = 8, r2 ;;
-        LOAD4(r4,r5,r6,r7) ;;   /* 12 - 15 : r4 - r7 */
-
-        add     r3 = 16, r2 ;;  /* 16 - 55 : f2 - f5, f16 - f31 */
-        FFILL4(f2,f3,f4,f5) ;;
-        FFILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;;
-        FFILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;;
-
-        /* Pop stack frame and return */
-        add     sp = (56 * 8), sp
-        br.ret.sptk.many b0 ;;
-
-        /* The trap handler */
-.L101:
-        /* Save exception pointer */
-        STOREGLOBAL(r6, caml_exception_pointer#)
-
-        /* Encode exception bucket as exception result */
-        or      r8 = 2, r8
-
-        /* Return it */
-        br.sptk .L104 ;;
-
-        .endp   caml_start_program#
-
-/* Raise an exception from C */
-
-        .global caml_raise_exception#
-        .proc   caml_raise_exception#
-        .align  16
-caml_raise_exception:
-        /* Allocate 64 "out" registers (for the Caml code) and no locals */
-        /* Since we don't return, don't bother saving the PFS */
-        alloc  r2 = ar.pfs, 0, 0, 64, 0
-
-        /* Move exn bucket where Caml expects it */
-        mov     r8 = r32 ;;
-
-        /* Perform "context switch" as per the Software Conventions Guide,
-           chapter 10 */
-        flushrs ;;                      /* flush dirty registers to stack */
-        mov     r14 = ar.rsc ;;
-        and     r2 = ~0x3, r14;;        /* set rsc.mode = 0 */
-        dep     r2 = r0, r2, 16, 4 ;;   /* clear rsc.loadrs */
-        mov     ar.rsc = r2 ;;          /* RSE is in enforced lazy mode */
-        invala ;;                       /* Invalidate ALAT */
-        LOADGLOBAL(r2, caml_saved_bsp#) ;;
-        mov     ar.bspstore = r2        /* Restore ar.bspstore */
-        LOADGLOBAL(r2, caml_saved_rnat#) ;;
-        mov     ar.rnat = r2            /* Restore ar.rnat */
-        mov     ar.rsc = r14 ;;         /* Restore original RSE mode */
-
-        /* Reload allocation pointers and exception pointer */
-        LOADGLOBAL(r4, caml_young_ptr#)
-        LOADGLOBAL(r5, caml_young_limit#)
-        LOADGLOBAL(r6, caml_exception_pointer#)
-
-        /* Say that we're back into Caml */
-        STOREGLOBAL(r0, caml_last_return_address#)
-
-        /* Raise the exception proper */
-        mov     sp = r6
-        add     r2 = 8, r6 ;;
-        ld8     r6 = [r6]
-        ld8     r2 = [r2] ;;
-        mov     b6 = r2 ;;
-
-       /* Branch to handler.  Must use a call so as to set up the
-          CFM and PFS correctly. */
-        br.call.sptk.many b0 = b6
-
-        .endp   caml_raise_exception
-
-/* Callbacks from C to Caml */
-
-        .global caml_callback_exn#
-        .proc   caml_callback_exn#
-        .align  16
-caml_callback_exn:
-        /* Initial shuffling of arguments */
-        ld8     r3 = [r32]              /* code pointer */
-        mov     r2 = r32
-        mov     r32 = r33 ;;            /* first arg */
-        mov     r33 = r2                /* environment */
-        mov     b6 = r3
-        br.sptk .L103 ;;
-
-        .endp   caml_callback_exn#
-
-        .global caml_callback2_exn#
-        .proc   caml_callback2_exn#
-        .align  16
-caml_callback2_exn:
-        /* Initial shuffling of arguments */
-        ADDRGLOBAL(r3, caml_apply2)    /* code pointer */
-        mov     r2 = r32
-        mov     r32 = r33               /* first arg */
-        mov     r33 = r34 ;;            /* second arg */
-        mov     r34 = r2                /* environment */
-        mov     b6 = r3
-        br.sptk .L103 ;;
-
-        .endp   caml_callback2_exn#
-
-        .global caml_callback3_exn#
-        .proc   caml_callback3_exn#
-        .align  16
-caml_callback3_exn:
-        /* Initial shuffling of arguments */
-        ADDRGLOBAL(r3, caml_apply3)    /* code pointer */
-        mov     r2 = r32
-        mov     r32 = r33               /* first arg */
-        mov     r33 = r34               /* second arg */
-        mov     r34 = r35 ;;            /* third arg */
-        mov     r35 = r2                /* environment */
-        mov     b6 = r3
-        br.sptk .L103 ;;
-
-        .endp   caml_callback3_exn#
-
-/* Glue code to call [caml_array_bound_error] */
-
-        .global caml_ml_array_bound_error#
-        .proc   caml_ml_array_bound_error#
-        .align  16
-caml_ml_array_bound_error:
-        ADDRGLOBAL(r2, @fptr(caml_array_bound_error#))
-        br.sptk caml_c_call             /* never returns */
-
-        .rodata
-
-        .global caml_system__frametable#
-        .type   caml_system__frametable#, @object
-        .size   caml_system__frametable#, 8
-caml_system__frametable:
-        data8   1               /* one descriptor */
-        data8   .L102           /* return address into callback */
-        data2   -1              /* negative frame size => use callback link */
-        data2   0               /* no roots here */
-        .align  8
-
-/* Global variables used by caml_raise_exception */
-
-        .common caml_saved_bsp#, 8, 8
-        .common caml_saved_rnat#, 8, 8

diff --git a/asmrun/m68k.S b/asmrun/m68k.S
deleted file mode 100644 (file)
index 559eacb..0000000
--- a/asmrun/m68k.S
+++ /dev/null
@@ -1,244 +0,0 @@
-|***********************************************************************
-|*                                                                     *
-|*                           Objective Caml                            *
-|*                                                                     *
-|*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
-|*                                                                     *
-|*  Copyright 1996 Institut National de Recherche en Informatique et   *
-|*  en Automatique.  All rights reserved.  This file is distributed    *
-|*  under the terms of the GNU Library General Public License, with    *
-|*  the special exception on linking described in file ../LICENSE.     *
-|*                                                                     *
-|***********************************************************************
-
-| $Id$
-
-| Asm part of the runtime system, Motorola 68k processor
-
-        .comm   _caml_requested_size, 4
-
-| Allocation
-
-        .text
-        .globl  _caml_call_gc
-        .globl  _caml_alloc1
-        .globl  _caml_alloc2
-        .globl  _caml_alloc3
-        .globl  _caml_allocN
-
-_caml_call_gc:
-    | Save desired size
-        movel   d5, _caml_requested_size
-    | Record lowest stack address and return address
-        movel   a7@, _caml_last_return_address
-        movel   a7, d5
-        addql   #4, d5
-        movel   d5, _caml_bottom_of_stack
-    | Record current allocation pointer (for debugging)
-        movel   d6, _caml_young_ptr
-    | Save all regs used by the code generator
-        movel   d4, a7@-
-        movel   d3, a7@-
-        movel   d2, a7@-
-        movel   d1, a7@-
-        movel   d0, a7@-
-        movel   a6, a7@-
-        movel   a5, a7@-
-        movel   a4, a7@-
-        movel   a3, a7@-
-        movel   a2, a7@-
-        movel   a1, a7@-
-        movel   a0, a7@-
-        movel   a7, _caml_gc_regs
-        fmovem  fp0-fp7, a7@-
-    | Call the garbage collector
-        jbsr    _caml_garbage_collection
-    | Restore all regs used by the code generator
-        fmovem  a7@+, fp0-fp7
-        movel   a7@+, a0
-        movel   a7@+, a1
-        movel   a7@+, a2
-        movel   a7@+, a3
-        movel   a7@+, a4
-        movel   a7@+, a5
-        movel   a7@+, a6
-        movel   a7@+, d0
-        movel   a7@+, d1
-        movel   a7@+, d2
-        movel   a7@+, d3
-        movel   a7@+, d4
-    | Reload allocation pointer and allocate block
-        movel   _caml_young_ptr, d6
-        subl    _caml_requested_size, d6
-    | Return to caller
-        rts
-
-_caml_alloc1:
-        subql   #8, d6
-        cmpl    _caml_young_limit, d6
-        bcs     L100
-        rts
-L100:   moveq   #8, d5
-        bra     _caml_call_gc
-
-_caml_alloc2:
-        subl    #12, d6
-        cmpl    _caml_young_limit, d6
-        bcs     L101
-        rts
-L101:   moveq   #12, d5
-        bra     _caml_call_gc
-
-_caml_alloc3:
-        subl    #16, d6
-        cmpl    _caml_young_limit, d6
-        bcs     L102
-        rts
-L102:   moveq   #16, d5
-        bra     _caml_call_gc
-
-_caml_allocN:
-        subl    d5, d6
-        cmpl    _caml_young_limit, d6
-        bcs     _caml_call_gc
-        rts
-
-| Call a C function from Caml
-
-        .globl  _caml_c_call
-
-_caml_c_call:
-    | Record lowest stack address and return address
-        movel   a7@+, _caml_last_return_address
-        movel   a7, _caml_bottom_of_stack
-    | Save allocation pointer and exception pointer
-        movel   d6, _caml_young_ptr
-        movel   d7, _caml_exception_pointer
-    | Call the function (address in a0)
-        jbsr    a0@
-    | Reload allocation pointer
-        movel   _caml_young_ptr, d6
-    | Return to caller
-        movel   _caml_last_return_address, a1
-        jmp     a1@
-
-| Start the Caml program
-
-        .globl  _caml_start_program
-
-_caml_start_program:
-    | Save callee-save registers
-        moveml  a2-a6/d2-d7, a7@-
-        fmovem  fp2-fp7, a7@-
-    | Initial code point is caml_program
-        lea     _caml_program, a5
-
-| Code shared between caml_start_program and caml_callback*
-
-L106:
-    | Build a callback link
-        movel   _caml_gc_regs, a7@-
-        movel   _caml_last_return_address, a7@-
-        movel   _caml_bottom_of_stack, a7@-
-    | Build an exception handler
-        pea     L108
-        movel   _caml_exception_pointer, a7@-
-        movel   a7, d7
-    | Load allocation pointer
-        movel   _caml_young_ptr, d6
-    | Call the Caml code
-        jbsr    a5@
-L107:
-    | Move result where C code expects it
-        movel   a0, d0
-    | Save allocation pointer
-        movel   d6, _caml_young_ptr
-    | Pop the exception handler
-        movel   a7@+, _caml_exception_pointer
-        addql   #4, a7
-L109:
-    | Pop the callback link, restoring the global variables
-    | used by caml_c_call
-        movel   a7@+, _caml_bottom_of_stack
-        movel   a7@+, _caml_last_return_address
-        movel   a7@+, _caml_gc_regs
-    | Restore callee-save registers and return
-        fmovem  a7@+, fp2-fp7
-        moveml  a7@+, a2-a6/d2-d7
-        unlk    a6
-        rts
-L108:
-    | Exception handler
-    | Save allocation pointer and exception pointer
-        movel   d6, _caml_young_ptr
-        movel   d7, _caml_exception_pointer
-    | Encode exception bucket as an exception result
-        movel   a0, d0
-        orl     #2, d0
-    | Return it
-        bra     L109
-
-| Raise an exception from C
-
-        .globl  _caml_raise_exception
-_caml_raise_exception:
-        movel   a7@(4), a0     | exception bucket
-        movel   _caml_young_ptr, d6
-        movel   _caml_exception_pointer, a7
-        movel   a7@+, d7
-        rts
-
-| Callback from C to Caml
-
-        .globl  _caml_callback_exn
-_caml_callback_exn:
-        link    a6, #0
-    | Save callee-save registers
-        moveml  a2-a6/d2-d7, a7@-
-        fmovem  fp2-fp7, a7@-
-    | Initial loading of arguments
-        movel   a6@(8), a1     | closure
-        movel   a6@(12), a0    | argument
-        movel   a1@(0), a5     | code pointer
-        bra     L106
-
-        .globl  _caml_callback2_exn
-_caml_callback2_exn:
-        link    a6, #0
-    | Save callee-save registers
-        moveml  a2-a6/d2-d7, a7@-
-        fmovem  fp2-fp7, a7@-
-    | Initial loading of arguments
-        movel   a6@(8), a2     | closure
-        movel   a6@(12), a0    | first argument
-        movel   a6@(16), a1    | second argument
-        lea     _caml_apply2, a5 | code pointer
-        bra     L106
-
-        .globl  _caml_callback3_exn
-_caml_callback3_exn:
-        link    a6, #0
-    | Save callee-save registers
-        moveml  a2-a6/d2-d7, a7@-
-        fmovem  fp2-fp7, a7@-
-    | Initial loading of arguments
-        movel   a6@(8), a3     | closure
-        movel   a6@(12), a0    | first argument
-        movel   a6@(16), a1    | second argument
-        movel   a6@(20), a2    | third argument
-        lea     _caml_apply3, a5 | code pointer
-        bra     L106
-
-        .globl  _caml_ml_array_bound_error
-_caml_ml_array_bound_error:
-    | Load address of [caml_array_bound_error] in a0 and call it
-        lea     _caml_array_bound_error, a0
-        bra     _caml_c_call
-
-        .data
-        .globl  _caml_system__frametable
-_caml_system__frametable:
-        .long   1               | one descriptor
-        .long   L107            | return address into callback
-        .word   -1              | negative frame size => use callback link
-        .word   0               | no roots here

diff --git a/asmrun/mips.s b/asmrun/mips.s
deleted file mode 100644 (file)
index 03fd623..0000000
--- a/asmrun/mips.s
+++ /dev/null
@@ -1,386 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 1996 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Asm part of the runtime system, Mips processor, IRIX n32 conventions */
-
-/* Allocation */
-
-        .text
-
-        .globl  caml_call_gc
-        .ent    caml_call_gc
-
-caml_call_gc:
-    /* Reserve stack space for registers and saved $gp */
-    /* 32 * 8 = 0x100 for float regs
-       22 * 4 = 0x58  for integer regs
-            8 = 0x8   for saved $gp ====> 0x160 total */
-        subu    $sp, $sp, 0x160
-    /* Reinit $gp */
-        .cpsetup $25, 0x158, caml_call_gc
-    /* Record return address */
-        sw      $31, caml_last_return_address
-    /* Record lowest stack address */
-        addu    $24, $sp, 0x160
-        sw      $24, caml_bottom_of_stack
-    /* Save pointer to register array */
-        addu    $24, $sp, 0x100
-        sw      $24, caml_gc_regs
-    /* Save current allocation pointer for debugging purposes */
-        sw      $22, caml_young_ptr
-    /* Save the exception handler (if e.g. a sighandler raises) */
-        sw      $30, caml_exception_pointer
-    /* Save all regs used by the code generator on the stack */
-        sw      $2, 2 * 4($24)
-        sw      $3, 3 * 4($24)
-        sw      $4, 4 * 4($24)
-        sw      $5, 5 * 4($24)
-        sw      $6, 6 * 4($24)
-        sw      $7, 7 * 4($24)
-        sw      $8, 8 * 4($24)
-        sw      $9, 9 * 4($24)
-        sw      $10, 10 * 4($24)
-        sw      $11, 11 * 4($24)
-        sw      $12, 12 * 4($24)
-        sw      $13, 13 * 4($24)
-        sw      $14, 14 * 4($24)
-        sw      $15, 15 * 4($24)
-        sw      $16, 16 * 4($24)
-        sw      $17, 17 * 4($24)
-        sw      $18, 18 * 4($24)
-        sw      $19, 19 * 4($24)
-        sw      $20, 20 * 4($24)
-        sw      $21, 21 * 4($24)
-        s.d     $f0, 0 * 8($sp)
-        s.d     $f1, 1 * 8($sp)
-        s.d     $f2, 2 * 8($sp)
-        s.d     $f3, 3 * 8($sp)
-        s.d     $f4, 4 * 8($sp)
-        s.d     $f5, 5 * 8($sp)
-        s.d     $f6, 6 * 8($sp)
-        s.d     $f7, 7 * 8($sp)
-        s.d     $f8, 8 * 8($sp)
-        s.d     $f9, 9 * 8($sp)
-        s.d     $f10, 10 * 8($sp)
-        s.d     $f11, 11 * 8($sp)
-        s.d     $f12, 12 * 8($sp)
-        s.d     $f13, 13 * 8($sp)
-        s.d     $f14, 14 * 8($sp)
-        s.d     $f15, 15 * 8($sp)
-        s.d     $f16, 16 * 8($sp)
-        s.d     $f17, 17 * 8($sp)
-        s.d     $f18, 18 * 8($sp)
-        s.d     $f19, 19 * 8($sp)
-        s.d     $f20, 20 * 8($sp)
-        s.d     $f21, 21 * 8($sp)
-        s.d     $f22, 22 * 8($sp)
-        s.d     $f23, 23 * 8($sp)
-        s.d     $f24, 24 * 8($sp)
-        s.d     $f25, 25 * 8($sp)
-        s.d     $f26, 26 * 8($sp)
-        s.d     $f27, 27 * 8($sp)
-        s.d     $f28, 28 * 8($sp)
-        s.d     $f29, 29 * 8($sp)
-        s.d     $f30, 30 * 8($sp)
-        s.d     $f31, 31 * 8($sp)
-    /* Call the garbage collector */
-        jal     caml_garbage_collection
-    /* Restore all regs used by the code generator */
-        addu    $24, $sp, 0x100
-        lw      $2, 2 * 4($24)
-        lw      $3, 3 * 4($24)
-        lw      $4, 4 * 4($24)
-        lw      $5, 5 * 4($24)
-        lw      $6, 6 * 4($24)
-        lw      $7, 7 * 4($24)
-        lw      $8, 8 * 4($24)
-        lw      $9, 9 * 4($24)
-        lw      $10, 10 * 4($24)
-        lw      $11, 11 * 4($24)
-        lw      $12, 12 * 4($24)
-        lw      $13, 13 * 4($24)
-        lw      $14, 14 * 4($24)
-        lw      $15, 15 * 4($24)
-        lw      $16, 16 * 4($24)
-        lw      $17, 17 * 4($24)
-        lw      $18, 18 * 4($24)
-        lw      $19, 19 * 4($24)
-        lw      $20, 20 * 4($24)
-        lw      $21, 21 * 4($24)
-        l.d     $f0, 0 * 8($sp)
-        l.d     $f1, 1 * 8($sp)
-        l.d     $f2, 2 * 8($sp)
-        l.d     $f3, 3 * 8($sp)
-        l.d     $f4, 4 * 8($sp)
-        l.d     $f5, 5 * 8($sp)
-        l.d     $f6, 6 * 8($sp)
-        l.d     $f7, 7 * 8($sp)
-        l.d     $f8, 8 * 8($sp)
-        l.d     $f9, 9 * 8($sp)
-        l.d     $f10, 10 * 8($sp)
-        l.d     $f11, 11 * 8($sp)
-        l.d     $f12, 12 * 8($sp)
-        l.d     $f13, 13 * 8($sp)
-        l.d     $f14, 14 * 8($sp)
-        l.d     $f15, 15 * 8($sp)
-        l.d     $f16, 16 * 8($sp)
-        l.d     $f17, 17 * 8($sp)
-        l.d     $f18, 18 * 8($sp)
-        l.d     $f19, 19 * 8($sp)
-        l.d     $f20, 20 * 8($sp)
-        l.d     $f21, 21 * 8($sp)
-        l.d     $f22, 22 * 8($sp)
-        l.d     $f23, 23 * 8($sp)
-        l.d     $f24, 24 * 8($sp)
-        l.d     $f25, 25 * 8($sp)
-        l.d     $f26, 26 * 8($sp)
-        l.d     $f27, 27 * 8($sp)
-        l.d     $f28, 28 * 8($sp)
-        l.d     $f29, 29 * 8($sp)
-        l.d     $f30, 30 * 8($sp)
-        l.d     $f31, 31 * 8($sp)
-    /* Reload new allocation pointer and allocation limit */
-        lw      $22, caml_young_ptr
-        lw      $23, caml_young_limit
-    /* Reload return address */
-        lw      $31, caml_last_return_address
-    /* Say that we are back into Caml code */
-        sw      $0, caml_last_return_address
-    /* Adjust return address to restart the allocation sequence */
-        subu    $31, $31, 16
-    /* Return */
-        .cpreturn
-        addu    $sp, $sp, 0x160
-        j       $31
-
-        .end    caml_call_gc
-
-/* Call a C function from Caml */
-
-        .globl  caml_c_call
-        .ent    caml_c_call
-
-caml_c_call:
-    /* Function to call is in $24 */
-    /* Set up $gp, saving caller's $gp in callee-save register $19 */
-        .cpsetup $25, $19, caml_c_call
-    /* Preload addresses of interesting global variables
-       in callee-save registers */
-        la      $16, caml_last_return_address
-        la      $17, caml_young_ptr
-    /* Save return address, bottom of stack, alloc ptr, exn ptr */
-        sw      $31, 0($16)     /* caml_last_return_address */
-        sw      $sp, caml_bottom_of_stack
-        sw      $22, 0($17)     /* caml_young_ptr */
-        sw      $30, caml_exception_pointer
-    /* Call C function */
-        move    $25, $24
-        jal     $24
-    /* Reload return address, alloc ptr, alloc limit */
-        lw      $31, 0($16)     /* caml_last_return_address */
-        lw      $22, 0($17)     /* caml_young_ptr */
-        lw      $23, caml_young_limit /* caml_young_limit */
-    /* Zero caml_last_return_address, indicating we're back in Caml code */
-        sw      $0, 0($16)      /* caml_last_return_address */
-    /* Restore $gp and return */
-        move    $gp, $19
-        j       $31
-        .end    caml_c_call
-
-/* Start the Caml program */
-
-        .globl  caml_start_program
-        .globl  stray_exn_handler
-        .ent    caml_start_program
-caml_start_program:
-    /* Reserve space for callee-save registers */
-        subu    $sp, $sp, 0x90
-    /* Setup $gp */
-        .cpsetup $25, 0x80, caml_start_program
-    /* Load in $24 the code address to call */
-        la      $24, caml_program
-    /* Code shared with caml_callback* */
-$103:
-    /* Save return address */
-        sd      $31, 0x88($sp)
-    /* Save all callee-save registers */
-        sd      $16, 0x0($sp)
-        sd      $17, 0x8($sp)
-        sd      $18, 0x10($sp)
-        sd      $19, 0x18($sp)
-        sd      $20, 0x20($sp)
-        sd      $21, 0x28($sp)
-        sd      $22, 0x30($sp)
-        sd      $23, 0x38($sp)
-        sd      $30, 0x40($sp)
-        s.d     $f20, 0x48($sp)
-        s.d     $f22, 0x50($sp)
-        s.d     $f24, 0x58($sp)
-        s.d     $f26, 0x60($sp)
-        s.d     $f28, 0x68($sp)
-        s.d     $f30, 0x70($sp)
-    /* Set up a callback link on the stack. */
-        subu    $sp, $sp, 16
-        lw      $2, caml_bottom_of_stack
-        sw      $2, 0($sp)
-        lw      $3, caml_last_return_address
-        sw      $3, 4($sp)
-        lw      $4, caml_gc_regs
-        sw      $4, 8($sp)
-    /* Set up a trap frame to catch exceptions escaping the Caml code */
-        subu    $sp, $sp, 16
-        lw      $30, caml_exception_pointer
-        sw      $30, 0($sp)
-        la      $2, $105
-        sw      $2, 4($sp)
-        sw      $gp, 8($sp)
-        move    $30, $sp
-    /* Reload allocation pointers */
-        lw      $22, caml_young_ptr
-        lw      $23, caml_young_limit
-    /* Say that we are back into Caml code */
-        sw      $0, caml_last_return_address
-    /* Call the Caml code */
-        move    $25, $24
-        jal     $24
-$104:
-    /* Pop the trap frame, restoring caml_exception_pointer */
-        lw      $24, 0($sp)
-        sw      $24, caml_exception_pointer
-        addu    $sp, $sp, 16
-$106:
-    /* Pop the callback link, restoring the global variables */
-        lw      $24, 0($sp)
-        sw      $24, caml_bottom_of_stack
-        lw      $25, 4($sp)
-        sw      $25, caml_last_return_address
-        lw      $24, 8($sp)
-        sw      $24, caml_gc_regs
-        addu    $sp, $sp, 16
-    /* Update allocation pointer */
-        sw      $22, caml_young_ptr
-    /* Reload callee-save registers and return */
-        ld      $31, 0x88($sp)
-        ld      $16, 0x0($sp)
-        ld      $17, 0x8($sp)
-        ld      $18, 0x10($sp)
-        ld      $19, 0x18($sp)
-        ld      $20, 0x20($sp)
-        ld      $21, 0x28($sp)
-        ld      $22, 0x30($sp)
-        ld      $23, 0x38($sp)
-        ld      $30, 0x40($sp)
-        l.d     $f20, 0x48($sp)
-        l.d     $f22, 0x50($sp)
-        l.d     $f24, 0x58($sp)
-        l.d     $f26, 0x60($sp)
-        l.d     $f28, 0x68($sp)
-        l.d     $f30, 0x70($sp)
-        .cpreturn
-        addu    $sp, $sp, 0x90
-        j       $31
-
-    /* The trap handler: encode exception bucket as an exception result
-       and return it */
-$105:
-        sw      $30, caml_exception_pointer
-        or      $2, $2, 2
-        b       $106
-
-        .end    caml_start_program
-
-/* Raise an exception from C */
-
-        .globl  caml_raise_exception
-        .ent    caml_raise_exception
-caml_raise_exception:
-    /* Setup $gp, discarding caller's $gp (we won't return) */
-        .cpsetup $25, $24, caml_raise_exception
-    /* Branch to exn handler */
-        move    $2, $4
-        lw      $22, caml_young_ptr
-        lw      $23, caml_young_limit
-        lw      $sp, caml_exception_pointer
-        lw      $30, 0($sp)
-        lw      $24, 4($sp)
-        lw      $gp, 8($sp)
-        addu    $sp, $sp, 16
-        j       $24
-
-        .end    caml_raise_exception
-
-/* Callback from C to Caml */
-
-        .globl  caml_callback_exn
-        .ent    caml_callback_exn
-caml_callback_exn:
-        subu    $sp, $sp, 0x90
-        .cpsetup $25, 0x80, caml_callback_exn
-    /* Initial shuffling of arguments */
-        move    $9, $4          /* closure */
-        move    $8, $5          /* argument */
-        lw      $24, 0($4)      /* code pointer */
-        b       $103
-        .end    caml_callback_exn
-
-        .globl  caml_callback2_exn
-        .ent    caml_callback2_exn
-caml_callback2_exn:
-        subu    $sp, $sp, 0x90
-        .cpsetup $25, 0x80, caml_callback2_exn
-    /* Initial shuffling of arguments */
-        move    $10, $4                 /* closure */
-        move    $8, $5                  /* first argument */
-        move    $9, $6                  /* second argument */
-        la      $24, caml_apply2        /* code pointer */
-        b       $103
-
-        .end    caml_callback2_exn
-
-        .globl  caml_callback3_exn
-        .ent    caml_callback3_exn
-caml_callback3_exn:
-        subu    $sp, $sp, 0x90
-        .cpsetup $25, 0x80, caml_callback3_exn
-    /* Initial shuffling of arguments */
-        move    $11, $4                 /* closure */
-        move    $8, $5                  /* first argument */
-        move    $9, $6                  /* second argument */
-        move    $10, $7                 /* third argument */
-        la      $24, caml_apply3        /* code pointer */
-        b       $103
-
-        .end    caml_callback3_exn
-
-/* Glue code to call [caml_array_bound_error] */
-
-        .globl  caml_ml_array_bound_error
-        .ent    caml_ml_array_bound_error
-
-caml_ml_array_bound_error:
-    /* Setup $gp, discarding caller's $gp (we won't return) */
-        .cpsetup $25, $24, caml_ml_array_bound_error
-        la      $24, caml_array_bound_error
-        jal     caml_c_call             /* never returns */
-
-        .end    caml_ml_array_bound_error
-
-        .rdata
-        .globl  caml_system__frametable
-caml_system__frametable:
-        .word   1               /* one descriptor */
-        .word   $104            /* return address into callback */
-        .half   -1              /* negative frame size => use callback link */
-        .half   0               /* no roots here */

diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c
index 84cfb590c90132b38481f0ac86e005ebaeddf89b..8625c545c85046a4cb3e2b9d7580b944d1bc3bf6 100644 (file)
--- a/asmrun/natdynlink.c
+++ b/asmrun/natdynlink.c
@@ -1,9 +1,23 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Alain Frisch, projet Gallium, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2007 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
 #include "misc.h"
 #include "mlvalues.h"
 #include "memory.h"
 #include "stack.h"
 #include "callback.h"
 #include "alloc.h"
+#include "intext.h"
 #include "natdynlink.h"
 #include "osdeps.h"
 #include "fail.h"
@@ -61,6 +75,7 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) {
   CAMLparam1 (symbol);
   CAMLlocal1 (result);
   void *sym,*sym2;
+  struct code_fragment * cf;
 
 #define optsym(n) getsym(handle,unit,n)
   char *unit;
@@ -81,8 +96,14 @@ CAMLprim value caml_natdynlink_run(void *handle, value symbol) {
 
   sym = optsym("__code_begin");
   sym2 = optsym("__code_end");
-  if (NULL != sym && NULL != sym2)
+  if (NULL != sym && NULL != sym2) {
     caml_page_table_add(In_code_area, sym, sym2);
+    cf = caml_stat_alloc(sizeof(struct code_fragment));
+    cf->code_start = (char *) sym;
+    cf->code_end = (char *) sym2;
+    cf->digest_computed = 0;
+    caml_ext_table_add(&caml_code_fragments_table, cf);
+  }
 
   entrypoint = optsym("__entry");
   if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0);

diff --git a/asmrun/power-aix.S b/asmrun/power-aix.S
deleted file mode 100644 (file)
index d63cdae..0000000
--- a/asmrun/power-aix.S
+++ /dev/null
@@ -1,513 +0,0 @@
-#*********************************************************************
-#*                                                                   *
-#*                          Objective Caml                           *
-#*                                                                   *
-#*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        *
-#*                                                                   *
-#* Copyright 1996 Institut National de Recherche en Informatique et  *
-#* en Automatique.  All rights reserved.  This file is distributed   *
-#* under the terms of the GNU Library General Public License, with   *
-#* the special exception on linking described in file ../LICENSE.    *
-#*                                                                   *
-#*********************************************************************
-
-# $Id$
-
-        .csect  .text[PR]
-
-#### Invoke the garbage collector. r0 contains the return address
-
-        .globl  .caml_call_gc
-.caml_call_gc:
-    # Set up stack frame
-        stwu    1, -0x1C0(1)
-    # 0x1C0 = 4*32 (int regs) + 8*32 (float regs) + 64 (space for C call)
-    # Record last return address into Caml code
-        lwz     11, L..caml_last_return_address(2)
-        stw     0, 0(11)
-    # Record return address into call_gc stub code
-        mflr    0
-        stw     0, 0x1C0+8(1)
-    # Record lowest stack address
-        lwz     11, L..caml_bottom_of_stack(2)
-        addi    0, 1, 0x1C0
-        stw     0, 0(11)
-    # Record pointer to register array
-        lwz     11, L..caml_gc_regs(2)
-        addi    0, 1, 8*32 + 64
-        stw     0, 0(11)
-    # Save current allocation pointer for debugging purposes
-        lwz     11, L..caml_young_ptr(2)
-        stw     31, 0(11)
-    # Save exception pointer (if e.g. a sighandler raises)
-        lwz     11, L..caml_exception_pointer(2)
-        stw     29, 0(11)
-    # Save all registers used by the code generator
-        addi    11, 1, 8*32 + 64 - 4
-        stwu    3, 4(11)
-        stwu    4, 4(11)
-        stwu    5, 4(11)
-        stwu    6, 4(11)
-        stwu    7, 4(11)
-        stwu    8, 4(11)
-        stwu    9, 4(11)
-        stwu    10, 4(11)
-        stwu    14, 4(11)
-        stwu    15, 4(11)
-        stwu    16, 4(11)
-        stwu    17, 4(11)
-        stwu    18, 4(11)
-        stwu    19, 4(11)
-        stwu    20, 4(11)
-        stwu    21, 4(11)
-        stwu    22, 4(11)
-        stwu    23, 4(11)
-        stwu    24, 4(11)
-        stwu    25, 4(11)
-        stwu    26, 4(11)
-        stwu    27, 4(11)
-        stwu    28, 4(11)
-        addi    11, 1, 64 - 8
-        stfdu   1, 8(11)
-        stfdu   2, 8(11)
-        stfdu   3, 8(11)
-        stfdu   4, 8(11)
-        stfdu   5, 8(11)
-        stfdu   6, 8(11)
-        stfdu   7, 8(11)
-        stfdu   8, 8(11)
-        stfdu   9, 8(11)
-        stfdu   10, 8(11)
-        stfdu   11, 8(11)
-        stfdu   12, 8(11)
-        stfdu   13, 8(11)
-        stfdu   14, 8(11)
-        stfdu   15, 8(11)
-        stfdu   16, 8(11)
-        stfdu   17, 8(11)
-        stfdu   18, 8(11)
-        stfdu   19, 8(11)
-        stfdu   20, 8(11)
-        stfdu   21, 8(11)
-        stfdu   22, 8(11)
-        stfdu   23, 8(11)
-        stfdu   24, 8(11)
-        stfdu   25, 8(11)
-        stfdu   26, 8(11)
-        stfdu   27, 8(11)
-        stfdu   28, 8(11)
-        stfdu   29, 8(11)
-        stfdu   30, 8(11)
-        stfdu   31, 8(11)
-    # Call the GC
-        bl      .caml_garbage_collection
-        or      0, 0, 0
-    # Reload new allocation pointer and allocation limit
-        lwz     11, L..caml_young_ptr(2)
-        lwz     31, 0(11)
-        lwz     11, L..caml_young_limit(2)
-        lwz     30, 0(11)
-    # Restore all regs used by the code generator
-        addi    11, 1, 8*32 + 64 - 4
-        lwzu    3, 4(11)
-        lwzu    4, 4(11)
-        lwzu    5, 4(11)
-        lwzu    6, 4(11)
-        lwzu    7, 4(11)
-        lwzu    8, 4(11)
-        lwzu    9, 4(11)
-        lwzu    10, 4(11)
-        lwzu    14, 4(11)
-        lwzu    15, 4(11)
-        lwzu    16, 4(11)
-        lwzu    17, 4(11)
-        lwzu    18, 4(11)
-        lwzu    19, 4(11)
-        lwzu    20, 4(11)
-        lwzu    21, 4(11)
-        lwzu    22, 4(11)
-        lwzu    23, 4(11)
-        lwzu    24, 4(11)
-        lwzu    25, 4(11)
-        lwzu    26, 4(11)
-        lwzu    27, 4(11)
-        lwzu    28, 4(11)
-        addi    11, 1, 64 - 8
-        lfdu    1, 8(11)
-        lfdu    2, 8(11)
-        lfdu    3, 8(11)
-        lfdu    4, 8(11)
-        lfdu    5, 8(11)
-        lfdu    6, 8(11)
-        lfdu    7, 8(11)
-        lfdu    8, 8(11)
-        lfdu    9, 8(11)
-        lfdu    10, 8(11)
-        lfdu    11, 8(11)
-        lfdu    12, 8(11)
-        lfdu    13, 8(11)
-        lfdu    14, 8(11)
-        lfdu    15, 8(11)
-        lfdu    16, 8(11)
-        lfdu    17, 8(11)
-        lfdu    18, 8(11)
-        lfdu    19, 8(11)
-        lfdu    20, 8(11)
-        lfdu    21, 8(11)
-        lfdu    22, 8(11)
-        lfdu    23, 8(11)
-        lfdu    24, 8(11)
-        lfdu    25, 8(11)
-        lfdu    26, 8(11)
-        lfdu    27, 8(11)
-        lfdu    28, 8(11)
-        lfdu    29, 8(11)
-        lfdu    30, 8(11)
-        lfdu    31, 8(11)
-    # Return to caller (the stub code), leaving return address into
-    # Caml code in the link register
-        lwz     0, 0x1C0+8(1)
-        mtctr   0
-        lwz     11, L..caml_last_return_address(2)
-        lwz     0, 0(11)
-        addic   0, 0, -16     # Restart the allocation (4 instructions)
-        mtlr    0
-    # Say we are back into Caml code
-        li      12, 0
-        stw     12, 0(11)     # 11 still points to caml_last_return_address
-    # Deallocate stack frame
-        addi    1, 1, 0x1C0
-    # Return
-        bctr
-
-#### Call a C function from Caml
-
-        .globl  .caml_c_call
-.caml_c_call:
-    # Save return address in 25
-        mflr    25
-    # Record lowest stack address and return address
-        lwz     27, L..caml_bottom_of_stack(2)
-        lwz     24, L..caml_last_return_address(2)
-        stw     1, 0(27)
-        stw     25, 0(24)
-    # Make the exception handler and alloc ptr available to the C code
-        lwz     27, L..caml_young_ptr(2)
-        lwz     26, L..caml_exception_pointer(2)
-        stw     31, 0(27)
-        stw     29, 0(26)
-    # Preserve RTOC and return address in callee-save registers
-    # The C function will preserve them, and the Caml code does not
-    # expect them to be preserved
-    # Return address is in 25, RTOC is in 26, pointer to caml_young_ptr in 27,
-    # pointer to caml_last_return_address is in 24
-    # Call the function (descriptor in 11)
-        lwz     0, 0(11)
-        mr      26, 2
-        mtlr    0
-        lwz     2, 4(11)
-        lwz     11, 8(11)
-        blrl
-    # Restore return address
-        mtlr    25
-    # Restore RTOC
-        mr      2, 26
-    # Reload allocation pointer
-        lwz     31, 0(27)     # 27 still points to caml_young_ptr
-    # Say we are back into Caml code
-        li      12, 0
-        stw     12, 0(24)     # 24 still points to caml_last_return_address
-    # Return to caller
-        blr
-
-#### Raise an exception from C
-
-        .globl  .caml_raise_exception
-.caml_raise_exception:
-    # Reload Caml global registers
-        lwz     4, L..caml_exception_pointer(2)
-        lwz     5, L..caml_young_ptr(2)
-        lwz     6, L..caml_young_limit(2)
-        lwz     1, 0(4)
-        lwz     31, 0(5)
-        lwz     30, 0(6)
-    # Say we are back into Caml code
-        lwz     4, L..caml_last_return_address(2)
-        li      0, 0
-        stw     0, 0(4)
-    # Pop trap frame
-        lwz     0, 0(1)
-        lwz     29, 4(1)
-        mtlr    0
-        lwz     2, 20(1)
-        addi    1, 1, 32
-    # Branch to handler
-        blr
-
-#### Start the Caml program
-
-        .globl  .caml_start_program
-.caml_start_program:
-        lwz     11, L..caml_program(2)
-
-#### Code shared between caml_start_program and caml_callback*
-
-L..102:
-        mflr    0
-    # Save return address
-        stw 0, 8(1)
-    # Save all callee-save registers
-        stw 13, -76(1)
-        stw 14, -72(1)
-        stw 15, -68(1)
-        stw 16, -64(1)
-        stw 17, -60(1)
-        stw 18, -56(1)
-        stw 19, -52(1)
-        stw 20, -48(1)
-        stw 21, -44(1)
-        stw 22, -40(1)
-        stw 23, -36(1)
-        stw 24, -32(1)
-        stw 25, -28(1)
-        stw 26, -24(1)
-        stw 27, -20(1)
-        stw 28, -16(1)
-        stw 29, -12(1)
-        stw 30, -8(1)
-        stw 31, -4(1)
-        stfd 14, -224(1)
-        stfd 15, -216(1)
-        stfd 16, -208(1)
-        stfd 17, -200(1)
-        stfd 18, -192(1)
-        stfd 19, -184(1)
-        stfd 20, -176(1)
-        stfd 21, -168(1)
-        stfd 22, -160(1)
-        stfd 23, -152(1)
-        stfd 24, -144(1)
-        stfd 25, -136(1)
-        stfd 26, -128(1)
-        stfd 27, -120(1)
-        stfd 28, -112(1)
-        stfd 29, -104(1)
-        stfd 30, -96(1)
-        stfd 31, -88(1)
-    # Allocate and link stack frame
-        stwu    1, -288(1)
-    # Set up a callback link
-        addi    1, 1, -32
-        lwz     9, L..caml_bottom_of_stack(2)
-        lwz     10, L..caml_last_return_address(2)
-        lwz     12, L..caml_gc_regs(2)
-        lwz     9, 0(9)
-        lwz     10, 0(10)
-        lwz     12, 0(12)
-        stw     9, 0(1)
-        stw     10, 4(1)
-        stw     12, 8(1)
-    # Build an exception handler to catch exceptions escaping out of Caml
-        bl      L..103
-        b       L..104
-L..103:
-        addi    1, 1, -32
-        lwz     9, L..caml_exception_pointer(2)
-        mflr    0
-        lwz     29, 0(9)
-        stw     0, 0(1)
-        stw     29, 4(1)
-        stw     2, 20(1)
-        mr      29, 1
-    # Reload allocation pointers
-        lwz     9, L..caml_young_ptr(2)
-        lwz     10, L..caml_young_limit(2)
-        lwz     31, 0(9)
-        lwz     30, 0(10)
-    # Say we are back into Caml code
-        lwz     9, L..caml_last_return_address(2)
-        li      0, 0
-        stw     0, 0(9)
-    # Call the Caml code
-        lwz     0, 0(11)
-        stw     2, 20(1)
-        mtlr    0
-        lwz     2, 4(11)
-L..105:
-        blrl
-        lwz     2, 20(1)
-    # Pop the trap frame, restoring caml_exception_pointer
-        lwz     9, 4(1)
-        lwz     10, L..caml_exception_pointer(2)
-        addi    1, 1, 32
-        stw     9, 0(10)
-    # Pop the callback link, restoring the global variables
-L..106:
-        lwz     7, 0(1)
-        lwz     8, 4(1)
-        lwz     9, 8(1)
-        lwz     10, L..caml_bottom_of_stack(2)
-        lwz     11, L..caml_last_return_address(2)
-        lwz     12, L..caml_gc_regs(2)
-        stw     7, 0(10)
-        stw     8, 0(11)
-        stw     9, 0(12)
-        addi    1, 1, 32
-    # Update allocation pointer
-        lwz     11, L..caml_young_ptr(2)
-        stw     31, 0(11)
-    # Deallocate stack frame
-        addi    1, 1, 288
-    # Restore callee-save registers
-        lwz 13, -76(1)
-        lwz 14, -72(1)
-        lwz 15, -68(1)
-        lwz 16, -64(1)
-        lwz 17, -60(1)
-        lwz 18, -56(1)
-        lwz 19, -52(1)
-        lwz 20, -48(1)
-        lwz 21, -44(1)
-        lwz 22, -40(1)
-        lwz 23, -36(1)
-        lwz 24, -32(1)
-        lwz 25, -28(1)
-        lwz 26, -24(1)
-        lwz 27, -20(1)
-        lwz 28, -16(1)
-        lwz 29, -12(1)
-        lwz 30, -8(1)
-        lwz 31, -4(1)
-        lfd 14, -224(1)
-        lfd 15, -216(1)
-        lfd 16, -208(1)
-        lfd 17, -200(1)
-        lfd 18, -192(1)
-        lfd 19, -184(1)
-        lfd 20, -176(1)
-        lfd 21, -168(1)
-        lfd 22, -160(1)
-        lfd 23, -152(1)
-        lfd 24, -144(1)
-        lfd 25, -136(1)
-        lfd 26, -128(1)
-        lfd 27, -120(1)
-        lfd 28, -112(1)
-        lfd 29, -104(1)
-        lfd 30, -96(1)
-        lfd 31, -88(1)
-    # Reload return address
-        lwz 0, 8(1)
-        mtlr 0
-    # Return
-        blr
-    # The trap handler:
-L..104:
-    # Update caml_exception_pointer
-        lwz     9, L..caml_exception_pointer(2)
-        stw     29, 0(9)
-    # Encode exception bucket as an exception result and return it
-        ori     3, 3, 2
-        b       L..106
-
-#### Callback from C to Caml
-
-        .globl  .caml_callback_exn
-.caml_callback_exn:
-    # Initial shuffling of arguments
-        mr      0, 3            # Closure
-        mr      3, 4            # Argument
-        mr      4, 0
-        lwz     11, 0(4)        # Code pointer
-        b       L..102
-
-        .globl  .caml_callback2_exn
-.caml_callback2_exn:
-        mr      0, 3            # Closure
-        mr      3, 4            # First argument
-        mr      4, 5            # Second argument
-        mr      5, 0
-        lwz     11, L..caml_apply2(2)
-        b       L..102
-
-        .globl  .caml_callback3_exn
-.caml_callback3_exn:
-        mr      0, 3            # Closure
-        mr      3, 4            # First argument
-        mr      4, 5            # Second argument
-        mr      5, 6            # Third argument
-        mr      6, 0
-        lwz     11, L..caml_apply3(2)
-        b       L..102
-
-#### Frame table
-
-        .csect  .data[RW]
-        .globl  caml_system__frametable
-caml_system__frametable:
-        .long   1               # one descriptor
-        .long   L..105 + 4      # return address into callback
-        .short  -1              # negative size count => use callback link
-        .short  0               # no roots here
-
-#### TOC entries
-
-        .toc
-L..caml_young_limit:
-        .tc     caml_young_limit[TC], caml_young_limit
-L..caml_young_ptr:
-        .tc     caml_young_ptr[TC], caml_young_ptr
-L..caml_bottom_of_stack:
-        .tc     caml_bottom_of_stack[TC], caml_bottom_of_stack
-L..caml_last_return_address:
-        .tc     caml_last_return_address[TC], caml_last_return_address
-L..caml_gc_regs:
-        .tc     caml_gc_regs[TC], caml_gc_regs
-L..caml_exception_pointer:
-        .tc     caml_exception_pointer[TC], caml_exception_pointer
-L..gc_entry_regs:
-        .tc     gc_entry_regs[TC], gc_entry_regs
-L..gc_entry_float_regs:
-        .tc     gc_entry_float_regs[TC], gc_entry_float_regs
-L..caml_program:
-        .tc     caml_program[TC], caml_program
-L..caml_apply2:
-        .tc     caml_apply2[TC], caml_apply2
-L..caml_apply3:
-        .tc     caml_apply3[TC], caml_apply3
-
-#### Function closures
-
-        .csect  caml_call_gc[DS]
-caml_call_gc:
-        .long   .caml_call_gc, TOC[tc0], 0
-
-        .globl  caml_c_call
-        .csect  caml_c_call[DS]
-caml_c_call:
-        .long   .caml_c_call, TOC[tc0], 0
-
-        .globl  caml_raise_exception
-        .csect  caml_raise_exception[DS]
-caml_raise_exception:
-        .long   .caml_raise_exception, TOC[tc0], 0
-
-        .globl  caml_start_program
-        .csect  caml_start_program[DS]
-caml_start_program:
-        .long   .caml_start_program, TOC[tc0], 0
-
-        .globl  caml_callback_exn
-        .csect  caml_callback_exn[DS]
-caml_callback_exn:
-        .long   .caml_callback_exn, TOC[tc0], 0
-
-        .globl  caml_callback2_exn
-        .csect  caml_callback2_exn[DS]
-caml_callback2_exn:
-        .long   .caml_callback2_exn, TOC[tc0], 0
-
-        .globl  caml_callback3_exn
-        .csect  caml_callback3_exn[DS]
-caml_callback3_exn:
-        .long   .caml_callback3_exn, TOC[tc0], 0

diff --git a/asmrun/power-elf.S b/asmrun/power-elf.S
index 968e3aeb887796f661add629e4ee943d29fe2396..8618b50a151d5cf97fd2a66fd4fccb86d4cbf489 100644 (file)
--- a/asmrun/power-elf.S
+++ b/asmrun/power-elf.S
@@ -1,15 +1,15 @@
-/*********************************************************************/
-/*                                                                   */
-/*                          Objective Caml                           */
-/*                                                                   */
-/*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        */
-/*                                                                   */
-/* Copyright 1996 Institut National de Recherche en Informatique et  */
-/* en Automatique.  All rights reserved.  This file is distributed   */
-/* under the terms of the GNU Library General Public License, with   */
-/* the special exception on linking described in file ../LICENSE.    */
-/*                                                                   */
-/*********************************************************************/
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
 
 /* $Id$ */
 
@@ -27,13 +27,16 @@
 
 /* Invoke the garbage collector. */
 
+        .globl  caml_system__code_begin
+caml_system__code_begin:
+        
         .globl  caml_call_gc
         .type   caml_call_gc, @function
 caml_call_gc:
     /* Set up stack frame */
         stwu    1, -0x1A0(1)
     /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */
-    /* Record return address into Caml code */
+    /* Record return address into OCaml code */
         mflr    0
         Storeglobal(0, caml_last_return_address, 11)
     /* Record lowest stack address */
@@ -169,7 +172,7 @@ caml_call_gc:
         Loadglobal(0, caml_last_return_address, 11)
         addic   0, 0, -16     /* Restart the allocation (4 instructions) */
         mtlr    0
-    /* Say we are back into Caml code */
+    /* Say we are back into OCaml code */
         li      12, 0
         Storeglobal(12, caml_last_return_address, 11)
     /* Deallocate stack frame */
@@ -177,7 +180,7 @@ caml_call_gc:
     /* Return */
         blr
 
-/* Call a C function from Caml */
+/* Call a C function from OCaml */
 
         .globl  caml_c_call
         .type   caml_c_call, @function
@@ -185,21 +188,21 @@ caml_c_call:
     /* Save return address */
         mflr    25
     /* Get ready to call C function (address in 11) */
-        mtlr    11
+        mtctr   11
     /* Record lowest stack address and return address */
         Storeglobal(1, caml_bottom_of_stack, 12)
         Storeglobal(25, caml_last_return_address, 12)
     /* Make the exception handler and alloc ptr available to the C code */
         Storeglobal(31, caml_young_ptr, 11)
         Storeglobal(29, caml_exception_pointer, 11)
-    /* Call the function (address in link register) */
-        blrl
+    /* Call the function (address in CTR register) */
+        bctrl
     /* Restore return address (in 25, preserved by the C function) */
         mtlr    25
     /* Reload allocation pointer and allocation limit*/
         Loadglobal(31, caml_young_ptr, 11)
         Loadglobal(30, caml_young_limit, 11)
-    /* Say we are back into Caml code */
+    /* Say we are back into OCaml code */
         li      12, 0
         Storeglobal(12, caml_last_return_address, 11)
     /* Return to caller */
@@ -210,11 +213,11 @@ caml_c_call:
         .globl  caml_raise_exception
         .type   caml_raise_exception, @function
 caml_raise_exception:
-    /* Reload Caml global registers */
+    /* Reload OCaml global registers */
         Loadglobal(1, caml_exception_pointer, 11)
         Loadglobal(31, caml_young_ptr, 11)
         Loadglobal(30, caml_young_limit, 11)
-    /* Say we are back into Caml code */
+    /* Say we are back into OCaml code */
         li      0, 0
         Storeglobal(0, caml_last_return_address, 11)
     /* Pop trap frame */
@@ -225,7 +228,7 @@ caml_raise_exception:
     /* Branch to handler */
         blr
 
-/* Start the Caml program */
+/* Start the OCaml program */
 
         .globl  caml_start_program
         .type   caml_start_program, @function
@@ -287,7 +290,7 @@ caml_start_program:
         stw     9, 0(1)
         stw     10, 4(1)
         stw     11, 8(1)
-    /* Build an exception handler to catch exceptions escaping out of Caml */
+    /* Build an exception handler to catch exceptions escaping out of OCaml */
         bl      .L103
         b       .L104
 .L103:
@@ -300,10 +303,10 @@ caml_start_program:
     /* Reload allocation pointers */
         Loadglobal(31, caml_young_ptr, 11)
         Loadglobal(30, caml_young_limit, 11)
-    /* Say we are back into Caml code */
+    /* Say we are back into OCaml code */
         li      0, 0
         Storeglobal(0, caml_last_return_address, 11)
-    /* Call the Caml code */
+    /* Call the OCaml code */
         mtlr    12
 .L105:
         blrl
@@ -375,7 +378,7 @@ caml_start_program:
         ori     3, 3, 2
         b       .L106
 
-/* Callback from C to Caml */
+/* Callback from C to OCaml */
 
         .globl  caml_callback_exn
         .type   caml_callback_exn, @function
@@ -408,6 +411,9 @@ caml_callback3_exn:
         Addrglobal(12, caml_apply3)
         b       .L102
 
+        .globl  caml_system__code_end
+caml_system__code_end:
+
 /* Frame table */
 
         .section ".data"

diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S
index 765de9c8ccc61b78e0af0466744ca9dbc6c21b22..843e056af288e2b0bd68e756cfea72e7b660db35 100644 (file)
--- a/asmrun/power-rhapsody.S
+++ b/asmrun/power-rhapsody.S
@@ -1,15 +1,15 @@
-/*********************************************************************/
-/*                                                                   */
-/*                          Objective Caml                           */
-/*                                                                   */
-/*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        */
-/*                                                                   */
-/* Copyright 1996 Institut National de Recherche en Informatique et  */
-/* en Automatique.  All rights reserved.  This file is distributed   */
-/* under the terms of the GNU Library General Public License, with   */
-/* the special exception on linking described in file ../LICENSE.    */
-/*                                                                   */
-/*********************************************************************/
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
 
 /* $Id$ */
 
@@ -41,6 +41,9 @@
 
         .text
 
+        .globl  _caml_system__code_begin
+_caml_system__code_begin:
+        
 /* Invoke the garbage collector. */
 
         .globl  _caml_call_gc
@@ -48,12 +51,17 @@ _caml_call_gc:
     /* Set up stack frame */
 #define FRAMESIZE (32*WORD + 32*8 + 32)
         stwu    r1, -FRAMESIZE(r1)
-    /* Record return address into Caml code */
+    /* Record return address into OCaml code */
         mflr    r0
         Storeglobal r0, _caml_last_return_address, r11
     /* Record lowest stack address */
         addi    r0, r1, FRAMESIZE
         Storeglobal r0, _caml_bottom_of_stack, r11
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        addi    r1, r1, -4096*WORD
+        stg     r0, 0(r1)
+        addi    r1, r1, 4096*WORD
     /* Record pointer to register array */
         addi    r0, r1, 8*32 + 32
         Storeglobal r0, _caml_gc_regs, r11
@@ -184,7 +192,7 @@ _caml_call_gc:
         Loadglobal r0, _caml_last_return_address, r11
         addic   r0, r0, -16     /* Restart the allocation (4 instructions) */
         mtlr    r0
-    /* Say we are back into Caml code */
+    /* Say we are back into OCaml code */
         li      r12, 0
         Storeglobal r12, _caml_last_return_address, r11
     /* Deallocate stack frame */
@@ -193,7 +201,7 @@ _caml_call_gc:
         blr
 #undef FRAMESIZE
 
-/* Call a C function from Caml */
+/* Call a C function from OCaml */
 
         .globl  _caml_c_call
 _caml_c_call:
@@ -204,6 +212,11 @@ _caml_c_call:
     /* Record lowest stack address and return address */
         Storeglobal r1, _caml_bottom_of_stack, r12
         Storeglobal r25, _caml_last_return_address, r12
+    /* Touch the stack to trigger a recoverable segfault
+       if insufficient space remains */
+        addi    r1, r1, -4096*WORD
+        stg     r0, 0(r1)
+        addi    r1, r1, 4096*WORD
     /* Make the exception handler and alloc ptr available to the C code */
         Storeglobal r31, _caml_young_ptr, r11
         Storeglobal r29, _caml_exception_pointer, r11
@@ -214,13 +227,13 @@ _caml_c_call:
     /* Reload allocation pointer and allocation limit*/
         Loadglobal r31, _caml_young_ptr, r11
         Loadglobal r30, _caml_young_limit, r11
-    /* Say we are back into Caml code */
+    /* Say we are back into OCaml code */
         li      r12, 0
         Storeglobal r12, _caml_last_return_address, r11
     /* Return to caller */
         blr
 
-/* Raise an exception from Caml */
+/* Raise an exception from OCaml */
         .globl  _caml_raise_exn
 _caml_raise_exn:
         addis   r11, 0, ha16(_caml_backtrace_active)
@@ -257,11 +270,11 @@ _caml_raise_exception:
         cmpwi   r11, 0
         bne     L112
 L113:
-    /* Reload Caml global registers */
+    /* Reload OCaml global registers */
         Loadglobal r1, _caml_exception_pointer, r11
         Loadglobal r31, _caml_young_ptr, r11
         Loadglobal r30, _caml_young_limit, r11
-    /* Say we are back into Caml code */
+    /* Say we are back into OCaml code */
         li      r0, 0
         Storeglobal r0, _caml_last_return_address, r11
     /* Pop trap frame */
@@ -282,7 +295,7 @@ L112:
         mr      r3, r28
         b       L113
 
-/* Start the Caml program */
+/* Start the OCaml program */
 
         .globl  _caml_start_program
 _caml_start_program:
@@ -343,7 +356,7 @@ L102:
         stg     r9, 0(r1)
         stg     r10, WORD(r1)
         stg     r11, 2*WORD(r1)
-    /* Build an exception handler to catch exceptions escaping out of Caml */
+    /* Build an exception handler to catch exceptions escaping out of OCaml */
         bl      L103
         b       L104
 L103:
@@ -356,10 +369,10 @@ L103:
     /* Reload allocation pointers */
         Loadglobal r31, _caml_young_ptr, r11
         Loadglobal r30, _caml_young_limit, r11
-    /* Say we are back into Caml code */
+    /* Say we are back into OCaml code */
         li      r0, 0
         Storeglobal r0, _caml_last_return_address, r11
-    /* Call the Caml code */
+    /* Call the OCaml code */
         mtctr    r12
 L105:
         bctrl
@@ -432,7 +445,7 @@ L104:
         b       L106
 #undef FRAMESIZE
 
-/* Callback from C to Caml */
+/* Callback from C to OCaml */
 
         .globl  _caml_callback_exn
 _caml_callback_exn:
@@ -462,6 +475,9 @@ _caml_callback3_exn:
         Addrglobal r12, _caml_apply3
         b       L102
 
+        .globl  _caml_system__code_end
+_caml_system__code_end:
+
 /* Frame table */
 
         .const

diff --git a/asmrun/roots.c b/asmrun/roots.c
index cb75a099cac30763997122cd88fb5ede92ca8824..edb7429d7d0757bc24b6a0fef7bc464bc15b98b4 100644 (file)
--- a/asmrun/roots.c
+++ b/asmrun/roots.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -129,7 +129,7 @@ void caml_init_frame_descriptors(void)
 
 char * caml_top_of_stack;
 char * caml_bottom_of_stack = NULL; /* no stack initially */
-uintnat caml_last_return_address = 1; /* not in Caml code initially */
+uintnat caml_last_return_address = 1; /* not in OCaml code initially */
 value * caml_gc_regs;
 intnat caml_globals_inited = 0;
 static intnat caml_globals_scanned = 0;

diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c
index f8f542ada958d93cc4f5acbc7307c0fd53edc0af..9d42718b8fb90ed260de5f6c86b7826fb9b25b92 100644 (file)
--- a/asmrun/signals_asm.c
+++ b/asmrun/signals_asm.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         */
 /*                                                                     */
@@ -46,14 +46,17 @@ extern void caml_win32_overflow_detection();
 #endif
 
 extern char * caml_code_area_start, * caml_code_area_end;
+extern char caml_system__code_begin, caml_system__code_end;
 
 #define Is_in_code_area(pc) \
  ( ((char *)(pc) >= caml_code_area_start && \
     (char *)(pc) <= caml_code_area_end)     \
-   || (Classify_addr(pc) & In_code_area) )
+|| ((char *)(pc) >= &caml_system__code_begin && \
+    (char *)(pc) <= &caml_system__code_end)     \
+|| (Classify_addr(pc) & In_code_area) )
 
 /* This routine is the common entry point for garbage collection
-   and signal handling.  It can trigger a callback to Caml code.
+   and signal handling.  It can trigger a callback to OCaml code.
    With system threads, this callback can cause a context switch.
    Hence [caml_garbage_collection] must not be called from regular C code
    (e.g. the [caml_alloc] function) because the context of the call
@@ -83,7 +86,7 @@ DECLARE_SIGNAL_HANDLER(handle_signal)
     caml_record_signal(sig);
   /* Some ports cache [caml_young_limit] in a register.
      Use the signal context to modify that register too, but only if
-     we are inside Caml code (not inside C code). */
+     we are inside OCaml code (not inside C code). */
 #if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT)
     if (Is_in_code_area(CONTEXT_PC))
       CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit;
@@ -175,6 +178,15 @@ DECLARE_SIGNAL_HANDLER(trap_handler)
 static char * system_stack_top;
 static char sig_alt_stack[SIGSTKSZ];
 
+#if defined(SYS_linux)
+/* PR#4746: recent Linux kernels with support for stack randomization
+   silently add 2 Mb of stack space on top of RLIMIT_STACK.
+   2 Mb = 0x200000, to which we add 8 kB (=0x2000) for overshoot. */
+#define EXTRA_STACK 0x202000
+#else
+#define EXTRA_STACK 0x2000
+#endif
+
 DECLARE_SIGNAL_HANDLER(segv_handler)
 {
   struct rlimit limit;
@@ -184,12 +196,12 @@ DECLARE_SIGNAL_HANDLER(segv_handler)
   /* Sanity checks:
      - faulting address is word-aligned
      - faulting address is within the stack
-     - we are in Caml code */
+     - we are in OCaml code */
   fault_addr = CONTEXT_FAULTING_ADDRESS;
   if (((uintnat) fault_addr & (sizeof(intnat) - 1)) == 0
       && getrlimit(RLIMIT_STACK, &limit) == 0
       && fault_addr < system_stack_top
-      && fault_addr >= system_stack_top - limit.rlim_cur - 0x2000
+      && fault_addr >= system_stack_top - limit.rlim_cur - EXTRA_STACK
 #ifdef CONTEXT_PC
       && Is_in_code_area(CONTEXT_PC)
 #endif

diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h
index 76552e5ee25a264bea2dde1cb5734637bc100fcd..830c43b386d7617fef15083dc35e5d1d99a9b302 100644 (file)
--- a/asmrun/signals_osdep.h
+++ b/asmrun/signals_osdep.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -15,26 +15,9 @@
 
 /* Processor- and OS-dependent signal interface */
 
-/****************** Alpha, all OS */
-
-#if defined(TARGET_alpha)
-
-  #define DECLARE_SIGNAL_HANDLER(name) \
-    static void name(int sig, int code, struct sigcontext * context)
-
-  #define SET_SIGACT(sigact,name) \
-     sigact.sa_handler = (void (*)(int)) (name); \
-     sigact.sa_flags = 0
-
-  typedef long context_reg;
-  #define CONTEXT_PC (context->sc_pc)
-  #define CONTEXT_EXCEPTION_POINTER (context->sc_regs[15])
-  #define CONTEXT_YOUNG_LIMIT (context->sc_regs[13])
-  #define CONTEXT_YOUNG_PTR (context->sc_regs[14])
-
 /****************** AMD64, Linux */
 
-#elif defined(TARGET_amd64) && defined (SYS_linux)
+#if defined(TARGET_amd64) && defined (SYS_linux)
 
   #define DECLARE_SIGNAL_HANDLER(name) \
     static void name(int sig, siginfo_t * info, ucontext_t * context)
@@ -78,7 +61,7 @@
 
 /****************** ARM, Linux */
 
-#elif defined(TARGET_arm) && defined (SYS_linux)
+#elif defined(TARGET_arm) && (defined(SYS_linux_eabi) || defined(SYS_linux_eabihf))
 
   #include <sys/ucontext.h>
 
@@ -177,23 +160,6 @@
 
   #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr)
 
-/****************** MIPS, all OS */
-
-#elif defined(TARGET_mips)
-
-  #define DECLARE_SIGNAL_HANDLER(name) \
-    static void name(int sig, int code, struct sigcontext * context)
-
-  #define SET_SIGACT(sigact,name) \
-     sigact.sa_handler = (void (*)(int)) (name); \
-     sigact.sa_flags = 0
-
-  typedef int context_reg;
-  #define CONTEXT_PC (context->sc_pc)
-  #define CONTEXT_EXCEPTION_POINTER (context->sc_regs[30])
-  #define CONTEXT_YOUNG_LIMIT (context->sc_regs[22])
-  #define CONTEXT_YOUNG_PTR (context->sc_regs[23])
-
 /****************** PowerPC, MacOS X */
 
 #elif defined(TARGET_power) && defined(SYS_rhapsody)

diff --git a/asmrun/sparc.S b/asmrun/sparc.S
index 38d0be0c16a5e1e7de0d08d72badc07b54f1b124..261743159b4c79702200d85122a55f190f210916 100644 (file)
--- a/asmrun/sparc.S
+++ b/asmrun/sparc.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -16,60 +16,6 @@
 /* Asm part of the runtime system for the Sparc processor.  */
 /* Must be preprocessed by cpp */
 
-/* SunOS 4 prefixes identifiers with _ */
-
-#if defined(SYS_sunos)
-
-#define Caml_young_limit _caml_young_limit
-#define Caml_young_ptr _caml_young_ptr
-#define Caml_bottom_of_stack _caml_bottom_of_stack
-#define Caml_last_return_address _caml_last_return_address
-#define Caml_gc_regs _caml_gc_regs
-#define Caml_exception_pointer _caml_exception_pointer
-#define Caml_allocN _caml_allocN
-#define Caml_call_gc _caml_call_gc
-#define Caml_garbage_collection _caml_garbage_collection
-#define Caml_c_call _caml_c_call
-#define Caml_start_program _caml_start_program
-#define Caml_program _caml_program
-#define Caml_raise_exception _caml_raise_exception
-#define Caml_callback_exn _caml_callback_exn
-#define Caml_callback2_exn _caml_callback2_exn
-#define Caml_callback3_exn _caml_callback3_exn
-#define Caml_apply2 _caml_apply2
-#define Caml_apply3 _caml_apply3
-#define Caml_raise _caml_raise
-#define Caml_system__frametable _caml_system__frametable
-#define Caml_ml_array_bound_error _caml_ml_array_bound_error
-#define Caml_array_bound_error _caml_array_bound_error
-
-#else
-
-#define Caml_young_limit caml_young_limit
-#define Caml_young_ptr caml_young_ptr
-#define Caml_bottom_of_stack caml_bottom_of_stack
-#define Caml_last_return_address caml_last_return_address
-#define Caml_gc_regs caml_gc_regs
-#define Caml_exception_pointer caml_exception_pointer
-#define Caml_allocN caml_allocN
-#define Caml_call_gc caml_call_gc
-#define Caml_garbage_collection caml_garbage_collection
-#define Caml_c_call caml_c_call
-#define Caml_start_program caml_start_program
-#define Caml_program caml_program
-#define Caml_raise_exception caml_raise_exception
-#define Caml_callback_exn caml_callback_exn
-#define Caml_callback2_exn caml_callback2_exn
-#define Caml_callback3_exn caml_callback3_exn
-#define Caml_apply2 caml_apply2
-#define Caml_apply3 caml_apply3
-#define Caml_raise caml_raise
-#define Caml_system__frametable caml_system__frametable
-#define Caml_ml_array_bound_error caml_ml_array_bound_error
-#define Caml_array_bound_error caml_array_bound_error
-
-#endif
-
 #ifndef SYS_solaris
 #define INDIRECT_LIMIT
 #endif
@@ -85,11 +31,15 @@
 /* Allocation functions */
 
         .text
-        .global Caml_allocN
-        .global Caml_call_gc
+
+        .global  caml_system__code_begin
+caml_system__code_begin:
+
+        .global caml_allocN
+        .global caml_call_gc
 
 /* Required size in %g2 */
-Caml_allocN:
+caml_allocN:
 #ifdef INDIRECT_LIMIT
         ld      [Alloc_limit], %g1
         sub     Alloc_ptr, %g2, Alloc_ptr
@@ -98,22 +48,22 @@ Caml_allocN:
         sub     Alloc_ptr, %g2, Alloc_ptr
         cmp     Alloc_ptr, Alloc_limit
 #endif
-        /*blu,pt  %icc, Caml_call_gc*/
-        blu     Caml_call_gc
+        /*blu,pt  %icc, caml_call_gc*/
+        blu     caml_call_gc
         nop
         retl
         nop
 
 /* Required size in %g2 */
-Caml_call_gc:
+caml_call_gc:
     /* Save exception pointer if GC raises */
-        Store(Exn_ptr, Caml_exception_pointer)
+        Store(Exn_ptr, caml_exception_pointer)
     /* Save current allocation pointer for debugging purposes */
-        Store(Alloc_ptr, Caml_young_ptr)
+        Store(Alloc_ptr, caml_young_ptr)
     /* Record lowest stack address */
-        Store(%sp, Caml_bottom_of_stack)
+        Store(%sp, caml_bottom_of_stack)
     /* Record last return address */
-        Store(%o7, Caml_last_return_address)
+        Store(%o7, caml_last_return_address)
     /* Allocate space on stack for caml_context structure and float regs */
         sub     %sp, 20*4 + 15*8, %sp
     /* Save int regs on stack and save it into caml_gc_regs */
@@ -139,7 +89,7 @@ L100:   add     %sp, 96 + 15*8, %g1
         st      %g4, [%g1 + 0x48]
         st      %g2, [%g1 + 0x4C]       /* Save required size */
         mov     %g1, %g2
-        Store(%g2, Caml_gc_regs)
+        Store(%g2, caml_gc_regs)
     /* Save the floating-point registers */
         add     %sp, 96, %g1
         std     %f0, [%g1]
@@ -158,7 +108,7 @@ L100:   add     %sp, 96 + 15*8, %g1
         std     %f26, [%g1 + 0x68]
         std     %f28, [%g1 + 0x70]
     /* Call the garbage collector */
-        call    Caml_garbage_collection
+        call    caml_garbage_collection
         nop
     /* Restore all regs used by the code generator */
         add     %sp, 96 + 15*8, %g1
@@ -199,116 +149,116 @@ L100:   add     %sp, 96 + 15*8, %g1
         ldd     [%g1 + 0x68], %f26
         ldd     [%g1 + 0x70], %f28
     /* Reload alloc ptr */
-        Load(Caml_young_ptr, Alloc_ptr)
+        Load(caml_young_ptr, Alloc_ptr)
     /* Allocate space for block */
 #ifdef INDIRECT_LIMIT
         ld      [Alloc_limit], %g1
         sub     Alloc_ptr, %g2, Alloc_ptr
         cmp     Alloc_ptr, %g1      /* Check that we have enough free space */
 #else
-        Load(Caml_young_limit,Alloc_limit)
+        Load(caml_young_limit,Alloc_limit)
         sub     Alloc_ptr, %g2, Alloc_ptr
         cmp     Alloc_ptr, Alloc_limit
 #endif
         blu     L100                /* If not, call GC again */
         nop
     /* Return to caller */
-        Load(Caml_last_return_address, %o7)
+        Load(caml_last_return_address, %o7)
         retl
         add     %sp, 20*4 + 15*8, %sp       /* in delay slot */
 
-/* Call a C function from Caml */
+/* Call a C function from Ocaml */
 
-        .global Caml_c_call
+        .global caml_c_call
 /* Function to call is in %g2 */
-Caml_c_call:
+caml_c_call:
     /* Record lowest stack address and return address */
-        Store(%sp, Caml_bottom_of_stack)
-        Store(%o7, Caml_last_return_address)
+        Store(%sp, caml_bottom_of_stack)
+        Store(%o7, caml_last_return_address)
     /* Save the exception handler and alloc pointer */
-        Store(Exn_ptr, Caml_exception_pointer)
-        sethi   %hi(Caml_young_ptr), %g1
+        Store(Exn_ptr, caml_exception_pointer)
+        sethi   %hi(caml_young_ptr), %g1
     /* Call the C function */
         call    %g2
-        st      Alloc_ptr, [%g1 + %lo(Caml_young_ptr)]   /* in delay slot */
+        st      Alloc_ptr, [%g1 + %lo(caml_young_ptr)]   /* in delay slot */
     /* Reload return address */
-        Load(Caml_last_return_address, %o7)
+        Load(caml_last_return_address, %o7)
     /* Reload alloc pointer */
-        sethi   %hi(Caml_young_ptr), %g1
+        sethi   %hi(caml_young_ptr), %g1
     /* Return to caller */
         retl
-        ld      [%g1 + %lo(Caml_young_ptr)], Alloc_ptr   /* in delay slot */
+        ld      [%g1 + %lo(caml_young_ptr)], Alloc_ptr   /* in delay slot */
 
-/* Start the Caml program */
+/* Start the Ocaml program */
 
-        .global Caml_start_program
-Caml_start_program:
+        .global caml_start_program
+caml_start_program:
     /* Save all callee-save registers */
         save    %sp, -96, %sp
     /* Address of code to call */
-        Address(Caml_program, %l2)
+        Address(caml_program, %l2)
 
     /* Code shared with caml_callback* */
 L108:
     /* Set up a callback link on the stack. */
         sub     %sp, 16, %sp
-        Load(Caml_bottom_of_stack, %l0)
-        Load(Caml_last_return_address, %l1)
-        Load(Caml_gc_regs, %l3)
+        Load(caml_bottom_of_stack, %l0)
+        Load(caml_last_return_address, %l1)
+        Load(caml_gc_regs, %l3)
         st      %l0, [%sp + 96]
         st      %l1, [%sp + 100]
-    /* Set up a trap frame to catch exceptions escaping the Caml code */
+    /* Set up a trap frame to catch exceptions escaping the Ocaml code */
         call    L111
         st      %l3, [%sp + 104]
         b       L110
         nop
 L111:   sub     %sp, 8, %sp
-        Load(Caml_exception_pointer, Exn_ptr)
+        Load(caml_exception_pointer, Exn_ptr)
         st      %o7, [%sp + 96]
         st      Exn_ptr, [%sp + 100]
         mov     %sp, Exn_ptr
     /* Reload allocation pointers */
-        Load(Caml_young_ptr, Alloc_ptr)
+        Load(caml_young_ptr, Alloc_ptr)
 #ifdef INDIRECT_LIMIT
-        Address(Caml_young_limit, Alloc_limit)
+        Address(caml_young_limit, Alloc_limit)
 #else
-        Load(Caml_young_limit, Alloc_limit)
+        Load(caml_young_limit, Alloc_limit)
 #endif
-    /* Call the Caml code */
+    /* Call the Ocaml code */
 L109:   call    %l2
         nop
     /* Pop trap frame and restore caml_exception_pointer */
         ld      [%sp + 100], Exn_ptr
         add     %sp, 8, %sp
-        Store(Exn_ptr, Caml_exception_pointer)
+        Store(Exn_ptr, caml_exception_pointer)
     /* Pop callback link, restoring the global variables */
 L112:   ld      [%sp + 96], %l0
         ld      [%sp + 100], %l1
         ld      [%sp + 104], %l2
-        Store(%l0, Caml_bottom_of_stack)
-        Store(%l1, Caml_last_return_address)
-        Store(%l2, Caml_gc_regs)
+        Store(%l0, caml_bottom_of_stack)
+        Store(%l1, caml_last_return_address)
+        Store(%l2, caml_gc_regs)
         add     %sp, 16, %sp
     /* Save allocation pointer */
-        Store(Alloc_ptr, Caml_young_ptr)
+        Store(Alloc_ptr, caml_young_ptr)
     /* Reload callee-save registers and return */
         ret
         restore %o0, 0, %o0     /* copy %o0 in this window to caller's %o0 */
 L110:
     /* The trap handler */
-        Store(Exn_ptr, Caml_exception_pointer)
+        Store(Exn_ptr, caml_exception_pointer)
     /* Encode exception bucket as an exception result */
         b       L112
         or      %o0, 2, %o0
 
 /* Raise an exception from C */
 
-        .global Caml_raise_exception
-Caml_raise_exception:
+        .global caml_raise_exception
+caml_raise_exception:
     /* Save exception bucket in a register outside the reg windows */
         mov     %o0, %g2
     /* Load exception pointer in a register outside the reg windows */
-        Load(Caml_exception_pointer, %g3)
+        Load(caml_exception_pointer, %g3)
     /* Pop some frames until the trap pointer is in the current frame. */
         cmp     %g3, %fp
         blt     L107                    /* if Exn_ptr < %fp, over */
@@ -319,11 +269,11 @@ L106:   restore
         nop
 L107:
     /* Reload allocation registers */
-        Load(Caml_young_ptr, Alloc_ptr)
+        Load(caml_young_ptr, Alloc_ptr)
 #ifdef INDIRECT_LIMIT
-        Address(Caml_young_limit, Alloc_limit)
+        Address(caml_young_limit, Alloc_limit)
 #else
-        Load(Caml_young_limit, Alloc_limit)
+        Load(caml_young_limit, Alloc_limit)
 #endif
     /* Branch to exception handler */
         mov     %g3, %sp
@@ -336,8 +286,8 @@ L107:
 
 /* Callbacks C -> ML */
 
-        .global Caml_callback_exn
-Caml_callback_exn:
+        .global caml_callback_exn
+caml_callback_exn:
     /* Save callee-save registers and return address */
         save    %sp, -96, %sp
     /* Initial shuffling of arguments */
@@ -347,8 +297,8 @@ Caml_callback_exn:
         b       L108
         ld      [%g1], %l2      /* code pointer */
 
-        .global Caml_callback2_exn
-Caml_callback2_exn:
+        .global caml_callback2_exn
+caml_callback2_exn:
     /* Save callee-save registers and return address */
         save    %sp, -104, %sp
     /* Initial shuffling of arguments */
@@ -356,12 +306,12 @@ Caml_callback2_exn:
         mov     %i1, %i0        /* first arg */
         mov     %i2, %i1        /* second arg */
         mov     %g1, %i2        /* environment */
-        sethi   %hi(Caml_apply2), %l2
+        sethi   %hi(caml_apply2), %l2
         b       L108
-        or      %l2, %lo(Caml_apply2), %l2
+        or      %l2, %lo(caml_apply2), %l2
 
-        .global Caml_callback3_exn
-Caml_callback3_exn:
+        .global caml_callback3_exn
+caml_callback3_exn:
     /* Save callee-save registers and return address */
         save    %sp, -104, %sp
     /* Initial shuffling of arguments */
@@ -370,38 +320,41 @@ Caml_callback3_exn:
         mov     %i2, %i1        /* second arg */
         mov     %i3, %i2        /* third arg */
         mov     %g1, %i3        /* environment */
-        sethi   %hi(Caml_apply3), %l2
+        sethi   %hi(caml_apply3), %l2
         b       L108
-        or      %l2, %lo(Caml_apply3), %l2
+        or      %l2, %lo(caml_apply3), %l2
 
 #ifndef SYS_solaris
 /* Glue code to call [caml_array_bound_error] */
 
-        .global Caml_ml_array_bound_error
-Caml_ml_array_bound_error:
-        Address(Caml_array_bound_error, %g2)
-        b       Caml_c_call
+        .global caml_ml_array_bound_error
+caml_ml_array_bound_error:
+        Address(caml_array_bound_error, %g2)
+        b       caml_c_call
         nop
 #endif
 
+        .global caml_system__code_end
+caml_system__code_end:
+
 #ifdef SYS_solaris
         .section ".rodata"
 #else
         .data
 #endif
-        .global Caml_system__frametable
+        .global caml_system__frametable
         .align  4               /* required for gas? */
-Caml_system__frametable:
+caml_system__frametable:
         .word   1               /* one descriptor */
         .word   L109            /* return address into callback */
         .half   -1              /* negative frame size => use callback link */
         .half   0               /* no roots */
 
 #ifdef SYS_solaris
-       .type Caml_allocN, #function
-       .type Caml_call_gc, #function
-        .type Caml_c_call, #function
-        .type Caml_start_program, #function
-        .type Caml_raise_exception, #function
-       .type Caml_system__frametable, #object
+       .type caml_allocN, #function
+       .type caml_call_gc, #function
+        .type caml_c_call, #function
+        .type caml_start_program, #function
+        .type caml_raise_exception, #function
+       .type caml_system__frametable, #object
 #endif

diff --git a/asmrun/stack.h b/asmrun/stack.h
index 62a33e71fce2331ee6ded39d6b9cdd832a177b63..9b575cb70cca6e5438cb2bef381e5979942cb44e 100644 (file)
--- a/asmrun/stack.h
+++ b/asmrun/stack.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -19,13 +19,6 @@
 #define CAML_STACK_H
 
 /* Macros to access the stack frame */
-#ifdef TARGET_alpha
-#define Saved_return_address(sp) *((intnat *)((sp) - 8))
-#define Already_scanned(sp, retaddr) ((retaddr) & 1L)
-#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - 8)) = (retaddr) | 1L)
-#define Mask_already_scanned(retaddr) ((retaddr) & ~1L)
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#endif
 
 #ifdef TARGET_sparc
 #define Saved_return_address(sp) *((intnat *)((sp) + 92))
@@ -41,17 +34,6 @@
 #endif
 #endif
 
-#ifdef TARGET_mips
-#define Saved_return_address(sp) *((intnat *)((sp) - 4))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 16))
-#endif
-
-#ifdef TARGET_hppa
-#define Stack_grows_upwards
-#define Saved_return_address(sp) *((intnat *)(sp))
-#define Callback_link(sp) ((struct caml_context *)((sp) - 24))
-#endif
-
 #ifdef TARGET_power
 #define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR))
 #define Already_scanned(sp, retaddr) ((retaddr) & 1)
@@ -65,34 +47,21 @@
 #define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size))
 #endif
 
-#ifdef TARGET_m68k
-#define Saved_return_address(sp) *((intnat *)((sp) - 4))
-#define Callback_link(sp) ((struct caml_context *)((sp) + 8))
-#endif
-
 #ifdef TARGET_arm
 #define Saved_return_address(sp) *((intnat *)((sp) - 4))
 #define Callback_link(sp) ((struct caml_context *)((sp) + 8))
 #endif
 
-#ifdef TARGET_ia64
-#define Saved_return_address(sp) *((intnat *)((sp) + 8))
-#define Already_scanned(sp, retaddr) ((retaddr) & 1L)
-#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) + 8)) = (retaddr) | 1L)
-#define Mask_already_scanned(retaddr) ((retaddr) & ~1L)
-#define Callback_link(sp) ((struct caml_context *)((sp) + 32))
-#endif
-
 #ifdef TARGET_amd64
 #define Saved_return_address(sp) *((intnat *)((sp) - 8))
 #define Callback_link(sp) ((struct caml_context *)((sp) + 16))
 #endif
 
-/* Structure of Caml callback contexts */
+/* Structure of OCaml callback contexts */
 
 struct caml_context {
-  char * bottom_of_stack;       /* beginning of Caml stack chunk */
-  uintnat last_retaddr;         /* last return address in Caml code */
+  char * bottom_of_stack;       /* beginning of OCaml stack chunk */
+  uintnat last_retaddr;         /* last return address in OCaml code */
   value * gc_regs;              /* pointer to register block */
 };
 

diff --git a/asmrun/startup.c b/asmrun/startup.c
index 8bfe762119ecd1d9830c726ad260181a894f9a10..a04fa84fcb24f0e564ca8224fc68ee317e3c7ed8 100644 (file)
--- a/asmrun/startup.c
+++ b/asmrun/startup.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -20,10 +20,12 @@
 #include "callback.h"
 #include "backtrace.h"
 #include "custom.h"
+#include "debugger.h"
 #include "fail.h"
 #include "freelist.h"
 #include "gc.h"
 #include "gc_ctrl.h"
+#include "intext.h"
 #include "memory.h"
 #include "misc.h"
 #include "mlvalues.h"
@@ -48,6 +50,7 @@ static void init_atoms(void)
 {
   extern struct segment caml_data_segments[], caml_code_segments[];
   int i;
+  struct code_fragment * cf;
 
   for (i = 0; i < 256; i++) {
     caml_atom_table[i] = Make_header(0, i, Caml_white);
@@ -57,9 +60,11 @@ static void init_atoms(void)
     caml_fatal_error("Fatal error: not enough memory for the initial page table");
 
   for (i = 0; caml_data_segments[i].begin != 0; i++) {
+    /* PR#5509: we must include the zero word at end of data segment,
+       because pointers equal to caml_data_segments[i].end are static data. */
     if (caml_page_table_add(In_static_data,
                             caml_data_segments[i].begin,
-                            caml_data_segments[i].end) != 0)
+                            caml_data_segments[i].end + sizeof(value)) != 0)
       caml_fatal_error("Fatal error: not enough memory for the initial page table");
   }
 
@@ -71,6 +76,13 @@ static void init_atoms(void)
     if (caml_code_segments[i].end > caml_code_area_end)
       caml_code_area_end = caml_code_segments[i].end;
   }
+  /* Register the code in the table of code fragments */
+  cf = caml_stat_alloc(sizeof(struct code_fragment));
+  cf->code_start = caml_code_area_start;
+  cf->code_end = caml_code_area_end;
+  cf->digest_computed = 0;
+  caml_ext_table_init(&caml_code_fragments_table, 8);
+  caml_ext_table_add(&caml_code_fragments_table, cf);
 }
 
 /* Configuration parameters and flags */

diff --git a/boot/.cvsignore b/boot/.cvsignore
deleted file mode 100644 (file)
index 5eeaef3..0000000
--- a/boot/.cvsignore
+++ /dev/null
@@ -1,7 +0,0 @@
-Saved
-ocamlrun
-ocamlyacc
-camlheader
-myocamlbuild
-myocamlbuild.native
-libcamlrun.a

diff --git a/boot/.ignore b/boot/.ignore
new file mode 100644 (file)
index 0000000..a0a2356
--- /dev/null
+++ b/boot/.ignore
@@ -0,0 +1,6 @@
+Saved
+ocamlrun
+ocamlyacc
+camlheader
+myocamlbuild
+myocamlbuild.native

diff --git a/boot/myocamlbuild.boot b/boot/myocamlbuild.boot
index 2c7c1f9235f58493519e7348bcc98ed09c4b9fda..0db6ddb845daec14508bc1761ec1086e39683db4 100755 (executable)
Binary files a/boot/myocamlbuild.boot and b/boot/myocamlbuild.boot differ

diff --git a/boot/ocamlc b/boot/ocamlc
index ddc3aa7c0d2efe0af0c2b928137e88f9642176d7..691e46b01d1da8cb0c820b3dec639b3afa626fac 100755 (executable)
Binary files a/boot/ocamlc and b/boot/ocamlc differ

diff --git a/boot/ocamldep b/boot/ocamldep
index 2dd0f9e3e2e6653547512427f8ba7496ae344122..6a0417d8037e014756b209b4e6c5b2b713a3c189 100755 (executable)
Binary files a/boot/ocamldep and b/boot/ocamldep differ

diff --git a/boot/ocamllex b/boot/ocamllex
index bebd06d950e3470cb8b9664b3149c4fa502323e3..ded272a4dd6e5acf77b53f2a77a174b8518211ce 100755 (executable)
Binary files a/boot/ocamllex and b/boot/ocamllex differ

diff --git a/build/.cvsignore b/build/.cvsignore
deleted file mode 100644 (file)
index 274c6e5..0000000
--- a/build/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-ocamlbuild_mixed_mode

diff --git a/build/.ignore b/build/.ignore
new file mode 100644 (file)
index 0000000..274c6e5
--- /dev/null
+++ b/build/.ignore
@@ -0,0 +1 @@
+ocamlbuild_mixed_mode

diff --git a/build/boot-c-parts.sh b/build/boot-c-parts.sh
index 9999392e376411cefb9e298192e87c8c0f3d0d58..fd5a35c72b71392cbba36e5557b052e742efba78 100755 (executable)
--- a/build/boot-c-parts.sh
+++ b/build/boot-c-parts.sh
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 cd `dirname $0`/..
 set -ex
 

diff --git a/build/boot.sh b/build/boot.sh
index 3de6006abf02834859cff511dfea01557bdfef03..79d5d20ba956bf9291933b6e2c12640dca3284d9 100755 (executable)
--- a/build/boot.sh
+++ b/build/boot.sh
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # $Id$
 cd `dirname $0`/..
 set -ex

diff --git a/build/buildbot b/build/buildbot
index 82cc26b1643dcb55bcc5869b240136bf121388d0..5d3cffbacc9b5e76f72e43184ced290fc7f9fa5c 100755 (executable)
--- a/build/buildbot
+++ b/build/buildbot
@@ -1,5 +1,17 @@
 #!/bin/sh
 
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # If you want to help me by participating to the build/test effort:
 #   http://gallium.inria.fr/~pouillar/ocaml-testing.html
 # -- Nicolas Pouillard

diff --git a/build/camlp4-bootstrap.sh b/build/camlp4-bootstrap.sh
index ef9a93c01b802b6f980dccff244a4901b691b180..612e060e9a8f9584a6cabf8fe9751f081421ff3d 100755 (executable)
--- a/build/camlp4-bootstrap.sh
+++ b/build/camlp4-bootstrap.sh
@@ -1,5 +1,17 @@
 #!/bin/sh
 
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # README: to bootstrap camlp4 have a look at build/camlp4-bootstrap-recipe.txt
 
 set -e

diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh
index 39b346172d8cd218a62ee285f754025baea1f6cb..442284d9d5f65dec15bbeb928c7e03da70658c7d 100755 (executable)
--- a/build/camlp4-byte-only.sh
+++ b/build/camlp4-byte-only.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
 #                                                                       #

diff --git a/build/camlp4-mkCamlp4Ast.sh b/build/camlp4-mkCamlp4Ast.sh
index 2a30b9ab22c271b5eab2f2d6c7efbaeebcd4c0e7..45311065c92f8287fa6a10fa27c2728b3be58cb8 100755 (executable)
--- a/build/camlp4-mkCamlp4Ast.sh
+++ b/build/camlp4-mkCamlp4Ast.sh
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2010 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # $Id$
 set -e
 cd `dirname $0`/..

diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh
index 629684b7b2d064ba8390b9488b027efb978c8446..d05932e2a6e62f1c6bdf4eecb7f5a0d84419ce7b 100755 (executable)
--- a/build/camlp4-native-only.sh
+++ b/build/camlp4-native-only.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
 #                                                                       #

diff --git a/build/camlp4-targets.sh b/build/camlp4-targets.sh
index 7c68906a485a408c34162418ce6810b25bf07280..4f4f51979e834d1e4440b10b51b5d31658e2feb2 100644 (file)
--- a/build/camlp4-targets.sh
+++ b/build/camlp4-targets.sh
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # $Id$
 CAMLP4_COMMON="\
   camlp4/Camlp4/Camlp4Ast.partial.ml \

diff --git a/build/distclean.sh b/build/distclean.sh
index b3efb3ab93c4e6c9a0838838c743dd1756fa9776..b336f9bb4b110e652e55a6402982bb124a4b979d 100755 (executable)
--- a/build/distclean.sh
+++ b/build/distclean.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/build/fastworld.sh b/build/fastworld.sh
index 8263908057c4b0c6fe0050a51be4fa0960ab333d..bbe42870ab242516b46fdbac09e0332003332778 100755 (executable)
--- a/build/fastworld.sh
+++ b/build/fastworld.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
 #                                                                       #

diff --git a/build/install.sh b/build/install.sh
index 264d598312753d1ca7c24fca524e501f45abe293..c0ad62f8ba10a67510c8b8ae6e6207657521282c 100755 (executable)
--- a/build/install.sh
+++ b/build/install.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/build/mixed-boot.sh b/build/mixed-boot.sh
index 122ff412f7acea196a31f9a3f22427b87d332555..133f8cff85fb6fdd39cbf3aa232dd01cc2bbc355 100755 (executable)
--- a/build/mixed-boot.sh
+++ b/build/mixed-boot.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/build/mkconfig.sh b/build/mkconfig.sh
index d7c2d91ebc510ccabc39479def714dc45f2ee28e..8cf1773dd9373431133371be8e6692d4694b5f9c 100755 (executable)
--- a/build/mkconfig.sh
+++ b/build/mkconfig.sh
@@ -1,5 +1,17 @@
 #!/bin/sh
 
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 cd `dirname $0`/..
 
 sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \

diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh
index 9c7eebd3c3ef35279cd4b6925fbe044d4a4dd64a..600878d8a847e8d766e568a8dfed6593087cd070 100755 (executable)
--- a/build/mkmyocamlbuild_config.sh
+++ b/build/mkmyocamlbuild_config.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/build/mkruntimedef.sh b/build/mkruntimedef.sh
index 54f7cc5c72de57a4a90d15a3d95e0295c16a3914..6cfd0749ce0b57b5fd69756bd8880bd7a6d7ee59 100755 (executable)
--- a/build/mkruntimedef.sh
+++ b/build/mkruntimedef.sh
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # $Id$
 echo 'let builtin_exceptions = [|'; \
 sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$|  \1;|p' byterun/fail.h | \

diff --git a/build/myocamlbuild.sh b/build/myocamlbuild.sh
index ad8b71a5f338408cd37242f2a541d8d0ff4e9d38..7a029a6a1255205b270d7a0826c760c1c5085dd0 100755 (executable)
--- a/build/myocamlbuild.sh
+++ b/build/myocamlbuild.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #   Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt  #
 #                                                                       #

diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh
index 2f226d422c49652f729aacf751b7490d5d444065..f669e8e685a04d14497eb099f4375ce44fa3eca7 100755 (executable)
--- a/build/ocamlbuild-byte-only.sh
+++ b/build/ocamlbuild-byte-only.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
 #                                                                       #

diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh
index c61f6a1ab908e155872a63231ce0d1f23f889486..f092a7892824a42110dc2574da8e799990822d68 100755 (executable)
--- a/build/ocamlbuild-native-only.sh
+++ b/build/ocamlbuild-native-only.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
 #                                                                       #

diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh
index 52bfb8fe24728c48526eda8ff7b5ce60da3ed4f7..9d6660803d8c702b0c2b4bf33ad83b3d104d8031 100755 (executable)
--- a/build/ocamlbuildlib-native-only.sh
+++ b/build/ocamlbuildlib-native-only.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
 #                                                                       #

diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh
index e3d9fedf27e4e811f8519556ce4fe38600a12898..a3890d038afe1a01edd3ce67da513480bb1b4a4d 100644 (file)
--- a/build/otherlibs-targets.sh
+++ b/build/otherlibs-targets.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
 #                                                                       #

diff --git a/build/partial-install.sh b/build/partial-install.sh
index 619976289038ff2562d59cb6548321e98856697b..81c0e116d73cd087aaccb8edeeda57e1b3407a69 100755 (executable)
--- a/build/partial-install.sh
+++ b/build/partial-install.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
 #                                                                       #
@@ -131,26 +131,28 @@ installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE
 installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE
 installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE
 
-cd camlp4
-CAMLP4DIR=$LIBDIR/camlp4
-for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do
-  echo "Installing $dir..."
-  mkdir -p $CAMLP4DIR/$dir
-  installdir     \
-    $dir/*.cm*   \
-    $dir/*.$O    \
-    $CAMLP4DIR/$dir
-done
-installdir \
-  camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \
-  camlp4fulllib.cma camlp4fulllib.cmxa \
-  camlp4o.cma camlp4of.cma camlp4oof.cma \
-  camlp4orf.cma camlp4r.cma camlp4rf.cma \
-  Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \
-  Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \
-  $CAMLP4DIR
-installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR
-cd ..
+if test -d camlp4; then
+  cd camlp4
+  CAMLP4DIR=$LIBDIR/camlp4
+  for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do
+    echo "Installing $dir..."
+    mkdir -p $CAMLP4DIR/$dir
+    installdir     \
+      $dir/*.cm*   \
+      $dir/*.$O    \
+      $CAMLP4DIR/$dir
+  done
+  installdir \
+    camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \
+    camlp4fulllib.cma camlp4fulllib.cmxa \
+    camlp4o.cma camlp4of.cma camlp4oof.cma \
+    camlp4orf.cma camlp4r.cma camlp4rf.cma \
+    Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \
+    Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \
+    $CAMLP4DIR
+  installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR
+  cd ..
+fi
 
 echo "Installing ocamlbuild..."
 cd ocamlbuild

diff --git a/build/targets.sh b/build/targets.sh
index 8d698423f73aff8783e29e9679c7420b50924ef5..d4e5a6a9392400d4f18d463906ecfd23e1684fa8 100644 (file)
--- a/build/targets.sh
+++ b/build/targets.sh
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/build/tolower.sed b/build/tolower.sed
index ccd55fca4cb84b2617c832285f741edab62e9397..ce0eb1651bd2cd00ba676dd79aaa6d350568d309 100644 (file)
--- a/build/tolower.sed
+++ b/build/tolower.sed
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # tolower.sed expands one ...<:lower<FOO>>... to ...foo... per line
 h
 s/.*<:lower<\(.*\)>>.*/\1/

diff --git a/build/world.all.sh b/build/world.all.sh
index d8a18abb97d621296f1e81efcc4f1db39335b025..bf456fc278d183a820d8e489d10cbc879ec3f4b5 100755 (executable)
--- a/build/world.all.sh
+++ b/build/world.all.sh
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # $Id$
 set -e
 cd `dirname $0`/..

diff --git a/build/world.byte.sh b/build/world.byte.sh
index d3e96dc4b6a4efc29d0f76adbb0feaff8d43cdd7..a30cda2ffee25f48245bfedd64e7416f4819cd7b 100755 (executable)
--- a/build/world.byte.sh
+++ b/build/world.byte.sh
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # $Id$
 set -e
 cd `dirname $0`/..

diff --git a/build/world.native.sh b/build/world.native.sh
index ac4a183237ac9f8d5fc972279303a4afda40c7d1..19526805e0ae358bfca443a189575f8c2d27985e 100755 (executable)
--- a/build/world.native.sh
+++ b/build/world.native.sh
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # $Id$
 set -e
 cd `dirname $0`/..

diff --git a/build/world.sh b/build/world.sh
index 534bce5459fe37ea9896ed1a5398a65f3b6a0f01..3b08dc78d278dfaeb6725d175c266ebae92b8f33 100755 (executable)
--- a/build/world.sh
+++ b/build/world.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
 #                                                                       #

diff --git a/bytecomp/.cvsignore b/bytecomp/.cvsignore
deleted file mode 100644 (file)
index d2f18a8..0000000
--- a/bytecomp/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-runtimedef.ml
-opcodes.ml

diff --git a/bytecomp/.ignore b/bytecomp/.ignore
new file mode 100644 (file)
index 0000000..d2f18a8
--- /dev/null
+++ b/bytecomp/.ignore
@@ -0,0 +1,2 @@
+runtimedef.ml
+opcodes.ml

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index b6c8f6fae8fc006a7d513afa5176aec982de8467..105be62d128c633b831aad3eab4958068f932ae8 100644 (file)
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -524,6 +524,10 @@ let rec comp_expr env exp sz cont =
       comp_expr env arg sz cont
   | Lprim(Pignore, [arg]) ->
       comp_expr env arg sz (add_const_unit cont)
+  | Lprim(Pdirapply loc, [func;arg])
+  | Lprim(Prevapply loc, [arg;func]) ->
+      let exp = Lapply(func, [arg], loc) in
+      comp_expr env exp sz cont
   | Lprim(Pnot, [arg]) ->
       let newcont =
         match cont with

diff --git a/bytecomp/bytegen.mli b/bytecomp/bytegen.mli
index 04265fde3093629d9a74bf22cb04c7f63d86b5d2..e0cd5f6179ff7057231fb94251d96e85676a4e2f 100644 (file)
--- a/bytecomp/bytegen.mli
+++ b/bytecomp/bytegen.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml
index ba08fc019ff9b1aad5241e8c1c95f0cbf0d38a55..21427c84405ee6d7a0851f4526bcb53a6411c0e2 100644 (file)
--- a/bytecomp/bytelibrarian.ml
+++ b/bytecomp/bytelibrarian.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -55,7 +55,7 @@ let add_ccobjs l =
     lib_dllibs := !lib_dllibs @ l.lib_dllibs
   end
 
-let copy_object_file oc name =
+let copy_object_file ppf oc name =
   let file_name =
     try
       find_in_path !load_path name
@@ -63,13 +63,12 @@ let copy_object_file oc name =
       raise(Error(File_not_found name)) in
   let ic = open_in_bin file_name in
   try
-    let buffer = String.create (String.length cmo_magic_number) in
-    really_input ic buffer 0 (String.length cmo_magic_number);
+    let buffer = input_bytes ic (String.length cmo_magic_number) in
     if buffer = cmo_magic_number then begin
       let compunit_pos = input_binary_int ic in
       seek_in ic compunit_pos;
       let compunit = (input_value ic : compilation_unit) in
-      Bytelink.check_consistency file_name compunit;
+      Bytelink.check_consistency ppf file_name compunit;
       copy_compunit ic oc compunit;
       close_in ic;
       [compunit]
@@ -78,7 +77,7 @@ let copy_object_file oc name =
       let toc_pos = input_binary_int ic in
       seek_in ic toc_pos;
       let toc = (input_value ic : library) in
-      List.iter (Bytelink.check_consistency file_name) toc.lib_units;
+      List.iter (Bytelink.check_consistency ppf file_name) toc.lib_units;
       add_ccobjs toc;
       List.iter (copy_compunit ic oc) toc.lib_units;
       close_in ic;
@@ -89,13 +88,13 @@ let copy_object_file oc name =
     End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name))
   | x -> close_in ic; raise x
 
-let create_archive file_list lib_name =
+let create_archive ppf file_list lib_name =
   let outchan = open_out_bin lib_name in
   try
     output_string outchan cma_magic_number;
     let ofs_pos_toc = pos_out outchan in
     output_binary_int outchan 0;
-    let units = List.flatten(List.map (copy_object_file outchan) file_list) in
+    let units = List.flatten(List.map (copy_object_file ppf outchan) file_list) in
     let toc =
       { lib_units = units;
         lib_custom = !Clflags.custom_runtime;
@@ -118,4 +117,5 @@ let report_error ppf = function
   | File_not_found name ->
       fprintf ppf "Cannot find file %s" name
   | Not_an_object_file name ->
-      fprintf ppf "The file %s is not a bytecode object file" name
+      fprintf ppf "The file %a is not a bytecode object file"
+        Location.print_filename name

diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli
index a4f9cc2f298ea3771bc0295e739df14a89e240bb..24201115932dddd82803c05b31191e85076da463 100644 (file)
--- a/bytecomp/bytelibrarian.mli
+++ b/bytecomp/bytelibrarian.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -21,7 +21,7 @@
       content table = list of compilation units
 *)
 
-val create_archive: string list -> string -> unit
+val create_archive: Format.formatter -> string list -> string -> unit
 
 type error =
     File_not_found of string

diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 479280087163486b7e8fe1fe637568dafac10bd2..4f93f0c2b532f78367aa793db2aa2a60d6c77dde 100644 (file)
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -29,6 +29,7 @@ type error =
   | File_exists of string
   | Cannot_open_dll of string
 
+
 exception Error of error
 
 type link_action =
@@ -115,8 +116,7 @@ let scan_file obj_name tolink =
       raise(Error(File_not_found obj_name)) in
   let ic = open_in_bin file_name in
   try
-    let buffer = String.create (String.length cmo_magic_number) in
-    really_input ic buffer 0 (String.length cmo_magic_number);
+    let buffer = input_bytes ic (String.length cmo_magic_number) in
     if buffer = cmo_magic_number then begin
       (* This is a .cmo file. It must be linked in any case.
          Read the relocation information to see which modules it
@@ -161,9 +161,10 @@ let scan_file obj_name tolink =
 (* Consistency check between interfaces *)
 
 let crc_interfaces = Consistbl.create ()
+let implementations_defined = ref ([] : (string * string) list)
 
-let check_consistency file_name cu =
-  try
+let check_consistency ppf file_name cu =
+  begin try
     List.iter
       (fun (name, crc) ->
         if name = cu.cu_name
@@ -172,6 +173,15 @@ let check_consistency file_name cu =
       cu.cu_imports
   with Consistbl.Inconsistency(name, user, auth) ->
     raise(Error(Inconsistent_import(name, user, auth)))
+  end;
+  begin try
+    let source = List.assoc cu.cu_name !implementations_defined in
+    Location.print_warning (Location.in_file file_name) ppf
+      (Warnings.Multiple_definition(cu.cu_name, Location.show_filename file_name, Location.show_filename source))
+  with Not_found -> ()
+  end;
+  implementations_defined :=
+    (cu.cu_name, file_name) :: !implementations_defined
 
 let extract_crc_interfaces () =
   Consistbl.extract crc_interfaces
@@ -182,16 +192,14 @@ let debug_info = ref ([] : (int * string) list)
 
 (* Link in a compilation unit *)
 
-let link_compunit output_fun currpos_fun inchan file_name compunit =
-  check_consistency file_name compunit;
+let link_compunit ppf output_fun currpos_fun inchan file_name compunit =
+  check_consistency ppf file_name compunit;
   seek_in inchan compunit.cu_pos;
-  let code_block = String.create compunit.cu_codesize in
-  really_input inchan code_block 0 compunit.cu_codesize;
+  let code_block = input_bytes inchan compunit.cu_codesize in
   Symtable.patch_object code_block compunit.cu_reloc;
   if !Clflags.debug && compunit.cu_debug > 0 then begin
     seek_in inchan compunit.cu_debug;
-    let buffer = String.create compunit.cu_debugsize in
-    really_input inchan buffer 0 compunit.cu_debugsize;
+    let buffer = input_bytes inchan compunit.cu_debugsize in
     debug_info := (currpos_fun(), buffer) :: !debug_info
   end;
   output_fun code_block;
@@ -200,10 +208,10 @@ let link_compunit output_fun currpos_fun inchan file_name compunit =
 
 (* Link in a .cmo file *)
 
-let link_object output_fun currpos_fun file_name compunit =
+let link_object ppf output_fun currpos_fun file_name compunit =
   let inchan = open_in_bin file_name in
   try
-    link_compunit output_fun currpos_fun inchan file_name compunit;
+    link_compunit ppf output_fun currpos_fun inchan file_name compunit;
     close_in inchan
   with
     Symtable.Error msg ->
@@ -213,14 +221,14 @@ let link_object output_fun currpos_fun file_name compunit =
 
 (* Link in a .cma file *)
 
-let link_archive output_fun currpos_fun file_name units_required =
+let link_archive ppf output_fun currpos_fun file_name units_required =
   let inchan = open_in_bin file_name in
   try
     List.iter
       (fun cu ->
          let name = file_name ^ "(" ^ cu.cu_name ^ ")" in
          try
-           link_compunit output_fun currpos_fun inchan name cu
+           link_compunit ppf output_fun currpos_fun inchan name cu
          with Symtable.Error msg ->
            raise(Error(Symbol_error(name, msg))))
       units_required;
@@ -229,11 +237,11 @@ let link_archive output_fun currpos_fun file_name units_required =
 
 (* Link in a .cmo or .cma file *)
 
-let link_file output_fun currpos_fun = function
+let link_file ppf output_fun currpos_fun = function
     Link_object(file_name, unit) ->
-      link_object output_fun currpos_fun file_name unit
+      link_object ppf output_fun currpos_fun file_name unit
   | Link_archive(file_name, units) ->
-      link_archive output_fun currpos_fun file_name units
+      link_archive ppf output_fun currpos_fun file_name units
 
 (* Output the debugging information *)
 (* Format is:
@@ -265,7 +273,7 @@ let make_absolute file =
 
 (* Create a bytecode executable file *)
 
-let link_bytecode tolink exec_name standalone =
+let link_bytecode ppf tolink exec_name standalone =
   Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *)
   let outchan =
     open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
@@ -276,7 +284,7 @@ let link_bytecode tolink exec_name standalone =
       try
         let header =
           if String.length !Clflags.use_runtime > 0
-          then "camlheader_ur" else "camlheader" in
+          then "camlheader_ur" else "camlheader" ^ !Clflags.runtime_variant in
         let inchan = open_in_bin (find_in_path !load_path header) in
         copy_file inchan outchan;
         close_in inchan
@@ -303,7 +311,7 @@ let link_bytecode tolink exec_name standalone =
     end;
     let output_fun = output_string outchan
     and currpos_fun () = pos_out outchan - start_code in
-    List.iter (link_file output_fun currpos_fun) tolink;
+    List.iter (link_file ppf output_fun currpos_fun) tolink;
     if standalone then Dll.close_all_dlls();
     (* The final STOP instruction *)
     output_byte outchan Opcodes.opSTOP;
@@ -402,7 +410,7 @@ let output_cds_file outfile =
 
 (* Output a bytecode executable as a C file *)
 
-let link_bytecode_as_c tolink outfile =
+let link_bytecode_as_c ppf tolink outfile =
   let outchan = open_out outfile in
   begin try
     (* The bytecode *)
@@ -424,7 +432,7 @@ let link_bytecode_as_c tolink outfile =
       output_code_string outchan code;
       currpos := !currpos + String.length code
     and currpos_fun () = !currpos in
-    List.iter (link_file output_fun currpos_fun) tolink;
+    List.iter (link_file ppf output_fun currpos_fun) tolink;
     (* The final STOP instruction *)
     Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP;
     (* The table of global data *)
@@ -458,6 +466,7 @@ let link_bytecode_as_c tolink outfile =
     close_out outchan
   with x ->
     close_out outchan;
+    remove_file outfile;
     raise x
   end;
   if !Clflags.debug then
@@ -466,8 +475,9 @@ let link_bytecode_as_c tolink outfile =
 (* Build a custom runtime *)
 
 let build_custom_runtime prim_name exec_name =
+  let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in
   Ccomp.call_linker Ccomp.Exe exec_name
-    ([prim_name] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"])
+    ([prim_name] @ List.rev !Clflags.ccobjs @ [runtime_lib])
     (Clflags.std_include_flag "-I" ^ " " ^ Config.bytecomp_c_libraries)
 
 let append_bytecode_and_cleanup bytecode_name exec_name prim_name =
@@ -490,7 +500,7 @@ let fix_exec_name name =
 
 (* Main entry point (build a custom runtime if needed) *)
 
-let link objfiles output_name =
+let link ppf objfiles output_name =
   let objfiles =
     if !Clflags.nopervasives then objfiles
     else if !Clflags.output_c_object then "stdlib.cma" :: objfiles
@@ -500,19 +510,23 @@ let link objfiles output_name =
   Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *)
   Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *)
   if not !Clflags.custom_runtime then
-    link_bytecode tolink output_name true
+    link_bytecode ppf tolink output_name true
   else if not !Clflags.output_c_object then begin
     let bytecode_name = Filename.temp_file "camlcode" "" in
     let prim_name = Filename.temp_file "camlprim" ".c" in
     try
-      link_bytecode tolink bytecode_name false;
+      link_bytecode ppf tolink bytecode_name false;
       let poc = open_out prim_name in
       output_string poc "\
         #ifdef __cplusplus\n\
         extern \"C\" {\n\
         #endif\n\
         #ifdef _WIN64\n\
+        #ifdef __MINGW32__\n\
+        typedef long long value;\n\
+        #else\n\
         typedef __int64 value;\n\
+        #endif\n\
         #else\n\
         typedef long value;\n\
         #endif\n";
@@ -539,15 +553,16 @@ let link objfiles output_name =
     if Sys.file_exists c_file then raise(Error(File_exists c_file));
     let temps = ref [] in
     try
-      link_bytecode_as_c tolink c_file;
+      link_bytecode_as_c ppf tolink c_file;
       if not (Filename.check_suffix output_name ".c") then begin
         temps := c_file :: !temps;
         if Ccomp.compile_file c_file <> 0 then raise(Error Custom_runtime);
         if not (Filename.check_suffix output_name Config.ext_obj) then begin
           temps := obj_file :: !temps;
           if not (
+            let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in
             Ccomp.call_linker Ccomp.MainDll output_name
-              ([obj_file] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"])
+              ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib])
               Config.bytecomp_c_libraries
            ) then raise (Error Custom_runtime);
         end
@@ -564,20 +579,25 @@ open Format
 
 let report_error ppf = function
   | File_not_found name ->
-      fprintf ppf "Cannot find file %s" name
+      fprintf ppf "Cannot find file %a" Location.print_filename name
   | Not_an_object_file name ->
-      fprintf ppf "The file %s is not a bytecode object file" name
+      fprintf ppf "The file %a is not a bytecode object file"
+        Location.print_filename name
   | Symbol_error(name, err) ->
-      fprintf ppf "Error while linking %s:@ %a" name
+      fprintf ppf "Error while linking %a:@ %a" Location.print_filename name
       Symtable.report_error err
   | Inconsistent_import(intf, file1, file2) ->
       fprintf ppf
-        "@[<hov>Files %s@ and %s@ \
+        "@[<hov>Files %a@ and %a@ \
                  make inconsistent assumptions over interface %s@]"
-        file1 file2 intf
+        Location.print_filename file1
+        Location.print_filename file2
+        intf
   | Custom_runtime ->
       fprintf ppf "Error while building custom runtime system"
   | File_exists file ->
-      fprintf ppf "Cannot overwrite existing file %s" file
+      fprintf ppf "Cannot overwrite existing file %a"
+        Location.print_filename file
   | Cannot_open_dll file ->
-      fprintf ppf "Error on dynamically loaded library: %s" file
+      fprintf ppf "Error on dynamically loaded library: %a"
+        Location.print_filename file

diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli
index 2e8f0cb31323e1575abddda72db7588675f8ad68..1366a1686f93422079927a1bfe910440596f57d2 100644 (file)
--- a/bytecomp/bytelink.mli
+++ b/bytecomp/bytelink.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -14,9 +14,9 @@
 
 (* Link .cmo files and produce a bytecode executable. *)
 
-val link: string list -> string -> unit
+val link : Format.formatter -> string list -> string -> unit
 
-val check_consistency: string -> Cmo_format.compilation_unit -> unit
+val check_consistency: Format.formatter -> string -> Cmo_format.compilation_unit -> unit
 
 val extract_crc_interfaces: unit -> (string * Digest.t) list
 

diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index e2b6ff54bbbe1255fe1dbe6513f6c8822f3f8029..089c5f6dc0a54803a1ef9215898a8fd54b28b2a3 100644 (file)
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -100,8 +100,7 @@ let read_member_info file =
     if Filename.check_suffix file ".cmo" then begin
     let ic = open_in_bin file in
     try
-      let buffer = String.create (String.length Config.cmo_magic_number) in
-      really_input ic buffer 0 (String.length Config.cmo_magic_number);
+      let buffer = input_bytes ic (String.length Config.cmo_magic_number) in
       if buffer <> Config.cmo_magic_number then
         raise(Error(Not_an_object_file file));
       let compunit_pos = input_binary_int ic in
@@ -124,10 +123,10 @@ let read_member_info file =
    Accumulate relocs, debug info, etc.
    Return size of bytecode. *)
 
-let rename_append_bytecode packagename oc mapping defined ofs prefix subst objfile compunit =
+let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst objfile compunit =
   let ic = open_in_bin objfile in
   try
-    Bytelink.check_consistency objfile compunit;
+    Bytelink.check_consistency ppf objfile compunit;
     List.iter
       (rename_relocation packagename objfile mapping defined ofs)
       compunit.cu_reloc;
@@ -148,20 +147,20 @@ let rename_append_bytecode packagename oc mapping defined ofs prefix subst objfi
 (* Same, for a list of .cmo and .cmi files.
    Return total size of bytecode. *)
 
-let rec rename_append_bytecode_list packagename oc mapping defined ofs prefix subst = function
+let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs prefix subst = function
     [] ->
       ofs
   | m :: rem ->
       match m.pm_kind with
       | PM_intf ->
-          rename_append_bytecode_list packagename oc mapping defined ofs prefix subst rem
+          rename_append_bytecode_list ppf packagename oc mapping defined ofs prefix subst rem
       | PM_impl compunit ->
           let size =
-            rename_append_bytecode packagename oc mapping defined ofs prefix subst
+            rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst
                                    m.pm_file compunit in
           let id = Ident.create_persistent m.pm_name in
           let root = Path.Pident (Ident.create_persistent prefix) in
-          rename_append_bytecode_list packagename
+          rename_append_bytecode_list ppf packagename
             oc mapping (id :: defined)
             (ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem
 
@@ -186,7 +185,7 @@ let build_global_target oc target_name members mapping pos coercion =
 
 (* Build the .cmo file obtained by packaging the given .cmo files. *)
 
-let package_object_files files targetfile targetname coercion =
+let package_object_files ppf files targetfile targetname coercion =
   let members =
     map_left_right read_member_info files in
   let unit_names =
@@ -203,7 +202,7 @@ let package_object_files files targetfile targetname coercion =
     let pos_depl = pos_out oc in
     output_binary_int oc 0;
     let pos_code = pos_out oc in
-    let ofs = rename_append_bytecode_list targetname oc mapping [] 0 targetname Subst.identity members in
+    let ofs = rename_append_bytecode_list ppf targetname oc mapping [] 0 targetname Subst.identity members in
     build_global_target oc targetname members mapping ofs coercion;
     let pos_debug = pos_out oc in
     if !Clflags.debug && !events <> [] then
@@ -233,19 +232,20 @@ let package_object_files files targetfile targetname coercion =
 
 (* The entry point *)
 
-let package_files files targetfile =
-  let files =
+let package_files ppf files targetfile =
+    let files =
     List.map
-      (fun f ->
+       (fun f ->
         try find_in_path !Config.load_path f
         with Not_found -> raise(Error(File_not_found f)))
-      files in
-  let prefix = chop_extensions targetfile in
-  let targetcmi = prefix ^ ".cmi" in
-  let targetname = String.capitalize(Filename.basename prefix) in
-  try
-    let coercion = Typemod.package_units files targetcmi targetname in
-    package_object_files files targetfile targetname coercion
+       files in
+    let prefix = chop_extensions targetfile in
+    let targetcmi = prefix ^ ".cmi" in
+    let targetname = String.capitalize(Filename.basename prefix) in
+    try
+      let coercion = Typemod.package_units files targetcmi targetname in
+    let ret = package_object_files ppf files targetfile targetname coercion in
+    ret
   with x ->
     remove_file targetfile; raise x
 
@@ -255,13 +255,17 @@ open Format
 
 let report_error ppf = function
     Forward_reference(file, ident) ->
-      fprintf ppf "Forward reference to %s in file %s" (Ident.name ident) file
+      fprintf ppf "Forward reference to %s in file %a" (Ident.name ident)
+        Location.print_filename file
   | Multiple_definition(file, ident) ->
-      fprintf ppf "File %s redefines %s" file (Ident.name ident)
+      fprintf ppf "File %a redefines %s"
+        Location.print_filename file
+        (Ident.name ident)
   | Not_an_object_file file ->
-      fprintf ppf "%s is not a bytecode object file" file
+      fprintf ppf "%a is not a bytecode object file"
+        Location.print_filename file
   | Illegal_renaming(file, id) ->
-      fprintf ppf "Wrong file naming: %s@ contains the code for@ %s"
-        file id
+      fprintf ppf "Wrong file naming: %a@ contains the code for@ %s"
+        Location.print_filename file id
   | File_not_found file ->
       fprintf ppf "File %s not found" file

diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli
index 836eb9c6374e666e657ad7017d73b8751fa2c4f8..696b12aa096f0886f901b2ec8fcdea68d7eefc1a 100644 (file)
--- a/bytecomp/bytepackager.mli
+++ b/bytecomp/bytepackager.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -15,7 +15,7 @@
 (* "Package" a set of .cmo files into one .cmo file having the
    original compilation units as sub-modules. *)
 
-val package_files: string list -> string -> unit
+val package_files: Format.formatter -> string list -> string -> unit
 
 type error =
     Forward_reference of string * Ident.t

diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml
index 16eaf23776fccfb64cba01dfee89270d3aac7cdf..518e2254fbdcb1a1a026f6c9c34105884f74c5e5 100644 (file)
--- a/bytecomp/bytesections.ml
+++ b/bytecomp/bytesections.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -48,14 +48,12 @@ let read_toc ic =
   let pos_trailer = in_channel_length ic - 16 in
   seek_in ic pos_trailer;
   let num_sections = input_binary_int ic in
-  let header = String.create(String.length Config.exec_magic_number) in
-  really_input ic header 0 (String.length Config.exec_magic_number);
+  let header = Misc.input_bytes ic (String.length Config.exec_magic_number) in
   if header <> Config.exec_magic_number then raise Bad_magic_number;
   seek_in ic (pos_trailer - 8 * num_sections);
   section_table := [];
   for i = 1 to num_sections do
-    let name = String.create 4 in
-    really_input ic name 0 4;
+    let name = Misc.input_bytes ic 4 in
     let len = input_binary_int ic in
     section_table := (name, len) :: !section_table
   done
@@ -81,10 +79,7 @@ let seek_section ic name =
 (* Return the contents of a section, as a string *)
 
 let read_section_string ic name =
-  let len = seek_section ic name in
-  let res = String.create len in
-  really_input ic res 0 len;
-  res
+  Misc.input_bytes ic (seek_section ic name)
 
 (* Return the contents of a section, as marshalled data *)
 

diff --git a/bytecomp/bytesections.mli b/bytecomp/bytesections.mli
index 5292cc1b4a17f0a908c19b686f771052ea274e94..c9264ad8998bac50bf03f3a21325740a17b61f4d 100644 (file)
--- a/bytecomp/bytesections.mli
+++ b/bytecomp/bytesections.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli
index c87e6df4e23576c8dece5f90791ed5419f9a66ce..b0cd05d67c32b0b97935f9648feaca9e91b0b3b7 100644 (file)
--- a/bytecomp/cmo_format.mli
+++ b/bytecomp/cmo_format.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml
index bcf66b4296ab99b83c4faf424883d850bcbe22b6..6109028fc59e9e0054fab5869548ad84a6ed0336 100644 (file)
--- a/bytecomp/dll.ml
+++ b/bytecomp/dll.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli
index fea455f7cb4a0a76a0fca4e2832a3da66a14c7dc..a4841d3d31a67bfbad1cf4216cbe5df8628b1c05 100644 (file)
--- a/bytecomp/dll.mli
+++ b/bytecomp/dll.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 2cec99dc8386005e2512dcce2167e3a2fb5a00a9..f9a33db731eaa126880fe295ba68fbb82fd1594d 100644 (file)
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
index fa20de18164c71caf8025d2bded421ffae65c769..55f3dff11d08b91e6e8ca71753dfc3c9ede0c8d8 100644 (file)
--- a/bytecomp/emitcode.mli
+++ b/bytecomp/emitcode.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml
index 4f4fa14fa197a101c0aa0aa042836251e0a7a663..7757c7d4842986c2423915cd9318117a5522a217 100644 (file)
--- a/bytecomp/instruct.ml
+++ b/bytecomp/instruct.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -107,5 +107,5 @@ let immed_min = -0x40000000
 and immed_max = 0x3FFFFFFF
 
 (* Actually the abstract machine accomodates -0x80000000 to 0x7FFFFFFF,
-   but these numbers overflow the Caml type int if the compiler runs on
+   but these numbers overflow the OCaml type int if the compiler runs on
    a 32-bit processor. *)

diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli
index 6b9367f9a0268685f781b7a7b28c1c3c469fc1e7..0fdccd298c3bca5eabc19bb518b95043d37e6505 100644 (file)
--- a/bytecomp/instruct.mli
+++ b/bytecomp/instruct.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
index 06523ebcc129dad1686a16f8edc95c00c40f1182..2e2875d82bdb5815e681592cfed18d680daae2ef 100644 (file)
--- a/bytecomp/lambda.ml
+++ b/bytecomp/lambda.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,6 +19,8 @@ open Asttypes
 type primitive =
     Pidentity
   | Pignore
+  | Prevapply of Location.t
+  | Pdirapply of Location.t
     (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t

diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
index e671b89156164de271060a5949f63b74b53842a9..c228d36d41e55cf01a9dee0669b4fc155bfce8a8 100644 (file)
--- a/bytecomp/lambda.mli
+++ b/bytecomp/lambda.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,6 +19,8 @@ open Asttypes
 type primitive =
     Pidentity
   | Pignore
+  | Prevapply of Location.t
+  | Pdirapply of Location.t
     (* Globals *)
   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t

diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
index 21006cc695e68a6363ff8d98a0d47bfc3556e4a0..f0b2237474097518cff4b1a7ef914cd0d07e29a1 100644 (file)
--- a/bytecomp/matching.ml
+++ b/bytecomp/matching.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -2037,7 +2037,7 @@ let combine_constructor arg ex_pat cstr partial ctx def
       List.fold_right
         (fun (ex, act) rem ->
           match ex with
-          | Cstr_exception path ->
+          | Cstr_exception (path, _) ->
               Lifthenelse(Lprim(Pintcomp Ceq,
                                 [Lprim(Pfield 0, [arg]); transl_path path]),
                           act, rem)
@@ -2542,13 +2542,7 @@ let compile_matching loc repr handler_fun arg pat_act_list partial =
 
 let partial_function loc () =
   (* [Location.get_pos_info] is too expensive *)
-  let fname = match loc.Location.loc_start.Lexing.pos_fname with
-              | "" -> !Location.input_name
-              | x -> x
-  in
-  let pos = loc.Location.loc_start in
-  let line = pos.Lexing.pos_lnum in
-  let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
+  let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
   Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
           [transl_path Predef.path_match_failure;
            Lconst(Const_block(0,

diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
index ebfed8410dbe018ded7a2d4d49235d795b83c392..d8ea791084071714384afe1da1d7cb5738f5bbe6 100644 (file)
--- a/bytecomp/matching.mli
+++ b/bytecomp/matching.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/meta.ml b/bytecomp/meta.ml
index a4beaf42248a6768e0b63965cc9f62770fdc1752..732bcc8a1a30ab25431c40d9986d064f9cf6a177 100644 (file)
--- a/bytecomp/meta.ml
+++ b/bytecomp/meta.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/meta.mli b/bytecomp/meta.mli
index 774c5f1374ad7b71a371cf23fde9188398b3fe64..93be656ad5e98553fc1167b5a0231f1a4b94fe3b 100644 (file)
--- a/bytecomp/meta.mli
+++ b/bytecomp/meta.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index 2f0508b2997f9edc531e3794bf336f69932afc88..f2aa87dc37be33ff2fda4ed950f187c4db3147d8 100644 (file)
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/printinstr.mli b/bytecomp/printinstr.mli
index e88e76ffc727adea2c38a1d92298696170f1573e..57cea578b5ba473abf6a1d9ba2b62e846271fcae 100644 (file)
--- a/bytecomp/printinstr.mli
+++ b/bytecomp/printinstr.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 9bfa099e154ef7cae3ac3ddfd1c654ea21549b18..cb99003b2901481234cd4d691be2df71725905bc 100644 (file)
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -92,6 +92,8 @@ let record_rep ppf r =
 let primitive ppf = function
   | Pidentity -> fprintf ppf "id"
   | Pignore -> fprintf ppf "ignore"
+  | Prevapply _ -> fprintf ppf "revapply"
+  | Pdirapply _ -> fprintf ppf "dirapply"
   | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
   | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
   | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag
@@ -297,7 +299,10 @@ let rec lam ppf = function
        | Lev_before -> "before"
        | Lev_after _  -> "after"
        | Lev_function -> "funct-body" in
-      fprintf ppf "@[<2>(%s %i-%i@ %a)@]" kind
+      fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind
+              ev.lev_loc.Location.loc_start.Lexing.pos_fname
+              ev.lev_loc.Location.loc_start.Lexing.pos_lnum
+              (if ev.lev_loc.Location.loc_ghost then "<ghost>" else "")
               ev.lev_loc.Location.loc_start.Lexing.pos_cnum
               ev.lev_loc.Location.loc_end.Lexing.pos_cnum
               lam expr

diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli
index 352d6d0248c1c62516e82e8221b8e94e25d428bd..0cbd59ed60f66663e8771d284b8280cf10e39904 100644 (file)
--- a/bytecomp/printlambda.mli
+++ b/bytecomp/printlambda.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,3 +18,4 @@ open Format
 
 val structured_constant: formatter -> structured_constant -> unit
 val lambda: formatter -> lambda -> unit
+val primitive: formatter -> primitive -> unit

diff --git a/bytecomp/runtimedef.mli b/bytecomp/runtimedef.mli
index 27309f60aac6fef7862d8a00a6cb63431b83e4fd..4892000947d310c67d1e20d71f82495ced940342 100644 (file)
--- a/bytecomp/runtimedef.mli
+++ b/bytecomp/runtimedef.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
index cd942ca2d5b613c3945a58fa687b3578a12bd975..1883f71518695f694a4af33f1f26e92028f7814f 100644 (file)
--- a/bytecomp/simplif.ml
+++ b/bytecomp/simplif.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -190,7 +190,23 @@ let simplify_exits lam =
   | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
-  | Lprim(p, ll) -> Lprim(p, List.map simplif ll)
+  | Lprim(p, ll) -> begin
+    let ll = List.map simplif ll in
+    match p, ll with
+        (* Simplify %revapply, for n-ary functions with n > 1 *)
+      | Prevapply loc, [x; Lapply(f, args, _)]
+      | Prevapply loc, [x; Levent (Lapply(f, args, _),_)] ->
+        Lapply(f, args@[x], loc)
+      | Prevapply loc, [x; f] -> Lapply(f, [x], loc)
+
+        (* Simplify %apply, for n-ary functions with n > 1 *)
+      | Pdirapply loc, [Lapply(f, args, _); x]
+      | Pdirapply loc, [Levent (Lapply(f, args, _),_); x] ->
+        Lapply(f, args@[x], loc)
+      | Pdirapply loc, [f; x] -> Lapply(f, [x], loc)
+
+      | _ -> Lprim(p, ll)
+     end
   | Lswitch(l, sw) ->
       let new_l = simplif l
       and new_consts =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
@@ -256,69 +272,113 @@ let simplify_exits lam =
   in
   simplif lam
 
+(* Compile-time beta-reduction of functions immediately applied:
+      Lapply(Lfunction(Curried, params, body), args, loc) ->
+        let paramN = argN in ... let param1 = arg1 in body
+      Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) ->
+        let paramN = argN in ... let param1 = arg1 in body
+   Assumes |args| = |params|.
+*)
+
+let beta_reduce params body args =
+  List.fold_left2 (fun l param arg -> Llet(Strict, param, arg, l))
+                  body params args
+
 (* Simplification of lets *)
 
 let simplify_lets lam =
 
-  (* First pass: count the occurrences of all identifiers *)
-  let occ = Hashtbl.create 83 in
+  (* Disable optimisations for bytecode compilation with -g flag *)
+  let optimize = !Clflags.native_code || not !Clflags.debug in
+
+  (* First pass: count the occurrences of all let-bound identifiers *)
+
+  let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in
+  (* The global table [occ] associates to each let-bound identifier
+     the number of its uses (as a reference):
+     - 0 if never used
+     - 1 if used exactly once in and not under a lambda or within a loop
+     - > 1 if used several times or under a lambda or within a loop.
+     The local table [bv] associates to each locally-let-bound variable
+     its reference count, as above.  [bv] is enriched at let bindings
+     but emptied when crossing lambdas and loops. *)
+
+  (* Current use count of a variable. *)
   let count_var v =
     try
       !(Hashtbl.find occ v)
     with Not_found ->
       0
-  and incr_var v =
+
+  (* Entering a [let].  Returns updated [bv]. *)
+  and bind_var bv v =
+    let r = ref 0 in
+    Hashtbl.add occ v r;
+    Tbl.add v r bv
+
+  (* Record a use of a variable *)
+  and use_var bv v n =
+    try
+      let r = Tbl.find v bv in r := !r + n
+    with Not_found ->
+      (* v is not locally bound, therefore this is a use under a lambda
+         or within a loop.  Increase use count by 2 -- enough so
+         that single-use optimizations will not apply. *)
     try
-      incr(Hashtbl.find occ v)
+      let r = Hashtbl.find occ v in r := !r + 2
     with Not_found ->
-      Hashtbl.add occ v (ref 1) in
+      (* Not a let-bound variable, ignore *)
+      () in
 
-  let rec count = function
-  | Lvar v -> incr_var v
+  let rec count bv = function
   | Lconst cst -> ()
-  | Lapply(l1, ll, _) -> count l1; List.iter count ll
-  | Lfunction(kind, params, l) -> count l
-  | Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
+  | Lvar v ->
+      use_var bv v 1
+  | Lapply(Lfunction(Curried, params, body), args, _)
+    when optimize && List.length params = List.length args ->
+      count bv (beta_reduce params body args)
+  | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _)
+    when optimize && List.length params = List.length args ->
+      count bv (beta_reduce params body args)
+  | Lapply(l1, ll, _) ->
+      count bv l1; List.iter (count bv) ll
+  | Lfunction(kind, params, l) ->
+      count Tbl.empty l
+  | Llet(str, v, Lvar w, l2) when optimize ->
       (* v will be replaced by w in l2, so each occurrence of v in l2
          increases w's refcount *)
-      count l2;
-      let vc = count_var v in
-      begin try
-        let r = Hashtbl.find occ w in r := !r + vc
-      with Not_found ->
-        Hashtbl.add occ w (ref vc)
-      end
+      count (bind_var bv v) l2;
+      use_var bv w (count_var v)
   | Llet(str, v, l1, l2) ->
-      count l2;
+      count (bind_var bv v) l2;
       (* If v is unused, l1 will be removed, so don't count its variables *)
-      if str = Strict || count_var v > 0 then count l1
+      if str = Strict || count_var v > 0 then count bv l1
   | Lletrec(bindings, body) ->
-      List.iter (fun (v, l) -> count l) bindings;
-      count body
-  | Lprim(p, ll) -> List.iter count ll
+      List.iter (fun (v, l) -> count bv l) bindings;
+      count bv body
+  | Lprim(p, ll) -> List.iter (count bv) ll
   | Lswitch(l, sw) ->
-      count_default sw ;
-      count l;
-      List.iter (fun (_, l) -> count l) sw.sw_consts;
-      List.iter (fun (_, l) -> count l) sw.sw_blocks
-  | Lstaticraise (i,ls) -> List.iter count ls
-  | Lstaticcatch(l1, (i,_), l2) ->
-      count l1; count l2
-  | Ltrywith(l1, v, l2) -> count l1; count l2
-  | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
-  | Lsequence(l1, l2) -> count l1; count l2
-  | Lwhile(l1, l2) -> count l1; count l2
-  | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3
+      count_default bv sw ;
+      count bv l;
+      List.iter (fun (_, l) -> count bv l) sw.sw_consts;
+      List.iter (fun (_, l) -> count bv l) sw.sw_blocks
+  | Lstaticraise (i,ls) -> List.iter (count bv) ls
+  | Lstaticcatch(l1, (i,_), l2) -> count bv l1; count bv l2
+  | Ltrywith(l1, v, l2) -> count bv l1; count bv l2
+  | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3
+  | Lsequence(l1, l2) -> count bv l1; count bv l2
+  | Lwhile(l1, l2) -> count Tbl.empty l1; count Tbl.empty l2
+  | Lfor(_, l1, l2, dir, l3) -> count bv l1; count bv l2; count Tbl.empty l3
   | Lassign(v, l) ->
       (* Lalias-bound variables are never assigned, so don't increase
          v's refcount *)
-      count l
-  | Lsend(_, m, o, ll, _) -> List.iter count (m::o::ll)
-  | Levent(l, _) -> count l
+      count bv l
+  | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll)
+  | Levent(l, _) -> count bv l
   | Lifused(v, l) ->
-      if count_var v > 0 then count l
+      if count_var v > 0 then count bv l
 
-  and count_default sw = match sw.sw_failaction with
+  and count_default bv sw = match sw.sw_failaction with
   | None -> ()
   | Some al ->
       let nconsts = List.length sw.sw_consts
@@ -326,18 +386,27 @@ let simplify_lets lam =
       if
         nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
       then begin (* default action will occur twice in native code *)
-        count al ; count al
+        count bv al ; count bv al
       end else begin (* default action will occur once *)
         assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
-        count al
+        count bv al
       end
   in
-  count lam;
+  count Tbl.empty lam;
+
   (* Second pass: remove Lalias bindings of unused variables,
      and substitute the bindings of variables used exactly once. *)
 
   let subst = Hashtbl.create 83 in
 
+(* This (small)  optimisation is always legal, it may uncover some
+   tail call later on. *)
+
+  let mklet (kind,v,e1,e2) = match e2 with
+  | Lvar w when optimize && Ident.same v w -> e1
+  | _ -> Llet (kind,v,e1,e2) in
+
+
   let rec simplif = function
     Lvar v as l ->
       begin try
@@ -346,33 +415,38 @@ let simplify_lets lam =
         l
       end
   | Lconst cst as l -> l
+  | Lapply(Lfunction(Curried, params, body), args, _)
+    when optimize && List.length params = List.length args ->
+      simplif (beta_reduce params body args)
+  | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _)
+    when optimize && List.length params = List.length args ->
+      simplif (beta_reduce params body args)
   | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
   | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
-  | Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
+  | Llet(str, v, Lvar w, l2) when optimize ->
       Hashtbl.add subst v (simplif (Lvar w));
       simplif l2
   | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody)
-    when not !Clflags.debug ->
+    when optimize ->
       let slinit = simplif linit in
       let slbody = simplif lbody in
       begin try
-        Llet(Variable, v, slinit, eliminate_ref v slbody)
+       mklet (Variable, v, slinit, eliminate_ref v slbody)
       with Real_reference ->
-        Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody)
+        mklet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody)
       end
   | Llet(Alias, v, l1, l2) ->
       begin match count_var v with
         0 -> simplif l2
-      | 1 when not !Clflags.debug ->
-             Hashtbl.add subst v (simplif l1); simplif l2
+      | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2
       | n -> Llet(Alias, v, simplif l1, simplif l2)
       end
   | Llet(StrictOpt, v, l1, l2) ->
       begin match count_var v with
         0 -> simplif l2
-      | n -> Llet(Alias, v, simplif l1, simplif l2)
+      | n -> mklet(Alias, v, simplif l1, simplif l2)
       end
-  | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
+  | Llet(kind, v, l1, l2) -> mklet(kind, v, simplif l1, simplif l2)
   | Lletrec(bindings, body) ->
       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
   | Lprim(p, ll) -> Lprim(p, List.map simplif ll)

diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli
index 2d9b352bb66d13a26aa955a059ba2cc47392b9aa..816c44b847ddd8debcd77db00dc07922e95b9541 100644 (file)
--- a/bytecomp/simplif.mli
+++ b/bytecomp/simplif.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml
index 4fa7b62ba7f0a05a50b9c95ba60d96219a93374d..ff193ee13254511384b78427957f793bf6073708 100644 (file)
--- a/bytecomp/switch.ml
+++ b/bytecomp/switch.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Luc Maranget, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli
index 33014c0f7a58bb8629c324cc37243e5758c7408d..69fc800d3818d67557893ea12d56d7fb8a9be15a 100644 (file)
--- a/bytecomp/switch.mli
+++ b/bytecomp/switch.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Luc Maranget, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 136144efa592acb8b53358eadf5b1b4150abba99..4e5f1475c90f751fd9231026df928381ae1e38a9 100644 (file)
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -55,6 +55,9 @@ let incr_numtable nt =
 let global_table = ref(empty_numtable : Ident.t numtable)
 and literal_table = ref([] : (int * structured_constant) list)
 
+let is_global_defined id =
+  Tbl.mem id (!global_table).num_tbl
+
 let slot_for_getglobal id =
   try
     find_numtable !global_table id

diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli
index cbef01e25fa375f66a2922e69865fe27bc749c42..d9a2be353144c6065cd7b500c9eb78bc5cb4e216 100644 (file)
--- a/bytecomp/symtable.mli
+++ b/bytecomp/symtable.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -33,6 +33,7 @@ val data_primitive_names: unit -> string
 val init_toplevel: unit -> (string * Digest.t) list
 val update_global_table: unit -> unit
 val get_global_value: Ident.t -> Obj.t
+val is_global_defined: Ident.t -> bool
 val assign_global_value: Ident.t -> Obj.t -> unit
 val get_global_position: Ident.t -> int
 val check_global_initialized: (reloc_info * int) list -> unit

diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index e18a13ba6ce785aaf0e155483b7a767e097523cd..843ef5a90a6ec5f53f75be1bc6df183e3c4c4e9a 100644 (file)
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -142,15 +142,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
                    (inh_init, obj_init, has_init)
                | Cf_init _ ->
                    (inh_init, obj_init, true)
-               | Cf_let (rec_flag, defs, vals) ->
-                   (inh_init,
-                    Translcore.transl_let rec_flag defs
-                      (List.fold_right
-                         (fun (id, expr) rem ->
-                            lsequence (Lifused(id, set_inst_var obj id expr))
-                                      rem)
-                         vals obj_init),
-                    has_init))
+            )
             str.cl_field
             (inh_init, obj_init obj, false)
         in
@@ -292,11 +284,6 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
                 (inh_init, cl_init,
                  Lvar (Meths.find name str.cl_meths) :: met_code @ methods,
                  values)
-            | Cf_let (rec_flag, defs, vals) ->
-                let vals =
-                  List.map (function (id, _) -> (Ident.name id, id)) vals
-                in
-                (inh_init, cl_init, methods, vals @ values)
             | Cf_init exp ->
                 (inh_init,
                  Lsequence(mkappl (oo_prim "add_initializer",

diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
index 4938278f7e3fd7672268d103fca82fd8fd83e8e2..7a5d6d1437ff29934c7becc5a06c5b19b90721e2 100644 (file)
--- a/bytecomp/translclass.mli
+++ b/bytecomp/translclass.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 3b0b0b0d54204f134eb093e52f2b0d08ae8d1966..77468a58f863e4338ba6ea4486ed94ccdf69428c 100644 (file)
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -28,6 +28,7 @@ type error =
     Illegal_letrec_pat
   | Illegal_letrec_expr
   | Free_super_var
+  | Unknown_builtin_primitive of string
 
 exception Error of Location.t * error
 
@@ -285,12 +286,13 @@ let prim_obj_dup =
   { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true;
     prim_native_name = ""; prim_native_float = false }
 
-let transl_prim prim args =
+let transl_prim loc prim args =
+  let prim_name = prim.prim_name in
   try
     let (gencomp, intcomp, floatcomp, stringcomp,
          nativeintcomp, int32comp, int64comp,
          simplify_constant_constructor) =
-      Hashtbl.find comparisons_table prim.prim_name in
+      Hashtbl.find comparisons_table prim_name in
     begin match args with
       [arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}]
       when simplify_constant_constructor ->
@@ -322,7 +324,11 @@ let transl_prim prim args =
     end
   with Not_found ->
   try
-    let p = Hashtbl.find primitives_table prim.prim_name in
+    let p =
+      match prim_name with
+          "%revapply" -> Prevapply loc
+        | "%apply" -> Pdirapply loc
+        | name -> Hashtbl.find primitives_table name in
     (* Try strength reduction based on the type of the argument *)
     begin match (p, args) with
         (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2)
@@ -342,6 +348,8 @@ let transl_prim prim args =
       | _ -> p
     end
   with Not_found ->
+    if String.length prim_name > 0 && prim_name.[0] = '%' then
+      raise(Error(loc, Unknown_builtin_primitive prim_name));
     Pccall prim
 
 
@@ -481,7 +489,9 @@ let rec push_defaults loc bindings pat_expr_list partial =
           Texp_match
             ({exp with exp_type = pat.pat_type; exp_desc =
               Texp_ident (Path.Pident param,
-                          {val_type = pat.pat_type; val_kind = Val_reg})},
+                          {val_type = pat.pat_type; val_kind = Val_reg;
+                           val_loc = Location.none;
+                          })},
              pat_expr_list, partial) }
       in
       push_defaults loc bindings
@@ -530,21 +540,16 @@ let primitive_is_ccall = function
 
 (* Assertions *)
 
-let assert_failed loc =
-  (* [Location.get_pos_info] is too expensive *)
-  let fname = match loc.Location.loc_start.Lexing.pos_fname with
-              | "" -> !Location.input_name
-              | x -> x
-  in
-  let pos = loc.Location.loc_start in
-  let line = pos.Lexing.pos_lnum in
-  let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
-  Lprim(Praise, [Lprim(Pmakeblock(0, Immutable),
+let assert_failed exp =
+  let (fname, line, char) =
+    Location.get_pos_info exp.exp_loc.Location.loc_start in
+  Lprim(Praise, [event_after exp
+    (Lprim(Pmakeblock(0, Immutable),
           [transl_path Predef.path_assert_failure;
            Lconst(Const_block(0,
               [Const_base(Const_string fname);
                Const_base(Const_int line);
-               Const_base(Const_int char)]))])])
+               Const_base(Const_int char)]))]))])
 ;;
 
 let rec cut n l =
@@ -620,7 +625,7 @@ and transl_exp0 e =
           wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
         | _ -> assert false
       else begin
-        let prim = transl_prim p args in
+        let prim = transl_prim e.exp_loc p args in
         match (prim, args) with
           (Praise, [arg1]) ->
             wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)]))
@@ -663,7 +668,7 @@ and transl_exp0 e =
           with Not_constant ->
             Lprim(Pmakeblock(n, Immutable), ll)
           end
-      | Cstr_exception path ->
+      | Cstr_exception (path, _) ->
           Lprim(Pmakeblock(0, Immutable), transl_path path :: ll)
       end
   | Texp_variant(l, arg) ->
@@ -767,8 +772,8 @@ and transl_exp0 e =
   | Texp_assert (cond) ->
       if !Clflags.noassert
       then lambda_unit
-      else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc)
-  | Texp_assertfalse -> assert_failed e.exp_loc
+      else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e)
+  | Texp_assertfalse -> assert_failed e
   | Texp_lazy e ->
       (* when e needs no computation (constants, identifiers, ...), we
          optimize the translation just as Lazy.lazy_from_val would
@@ -787,12 +792,13 @@ and transl_exp0 e =
           begin match e.exp_type.desc with
           (* the following may represent a float/forward/lazy: need a
              forward_tag *)
-          | Tvar | Tlink _ | Tsubst _ | Tunivar
+          | Tvar _ | Tlink _ | Tsubst _ | Tunivar _
           | Tpoly(_,_) | Tfield(_,_,_,_) ->
               Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
           (* the following cannot be represented as float/forward/lazy:
              optimize *)
-          | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _
+          | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil
+          | Tvariant _
               -> transl_exp e
           (* optimize predefined types (excepted float) *)
           | Tconstr(_,_,_) ->
@@ -934,6 +940,7 @@ and transl_let rec_flag pat_expr_list body =
           (fun (pat, expr) ->
             match pat.pat_desc with
               Tpat_var id -> id
+            | Tpat_alias ({pat_desc=Tpat_any}, id) -> id
             | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))
         pat_expr_list in
       let transl_case (pat, expr) id =
@@ -1048,3 +1055,5 @@ let report_error ppf = function
   | Free_super_var ->
       fprintf ppf
         "Ancestor names can only be used to select inherited methods"
+  | Unknown_builtin_primitive prim_name ->
+    fprintf ppf  "Unknown builtin primitive \"%s\"" prim_name

diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index baac05567591f27d1c760f9ad4f8f847e8801fbc..5cb22775bfb2a644e1fe0f9c6813ba4736de0854 100644 (file)
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -37,6 +37,7 @@ type error =
     Illegal_letrec_pat
   | Illegal_letrec_expr
   | Free_super_var
+  | Unknown_builtin_primitive of string
 
 exception Error of Location.t * error
 

diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index bd6107f03561a0df701fb7ad26bc7a4e3282180c..38eab85431e2f3a971c176e673d50554c32a6de5 100644 (file)
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -109,13 +109,7 @@ let mod_prim name =
     fatal_error ("Primitive " ^ name ^ " not found.")
 
 let undefined_location loc =
-  (* Confer Translcore.assert_failed *)
-  let fname = match loc.Location.loc_start.Lexing.pos_fname with
-              | "" -> !Location.input_name
-              | x -> x in
-  let pos = loc.Location.loc_start in
-  let line = pos.Lexing.pos_lnum in
-  let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
+  let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
   Lconst(Const_block(0,
                      [Const_base(Const_string fname);
                       Const_base(Const_int line);
@@ -267,7 +261,7 @@ let rec transl_module cc rootpath mexp =
   | Tmod_constraint(arg, mty, ccarg) ->
       transl_module (compose_coercions cc ccarg) rootpath arg
   | Tmod_unpack(arg, _) ->
-      Translcore.transl_exp arg
+      apply_coercion cc (Translcore.transl_exp arg)
 
 and transl_structure fields cc rootpath = function
     [] ->

diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index 9e47ca5e6aca92378e0efdb81d337c63c4ac8d32..5b6d0a0065f20e4233ba7e860ea3d613710a84c5 100644 (file)
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
index a0df551d80c3beae0bdbd3ea771baabc73a971f0..f72e34b0ae7ba58617d9a8155c1fe533d3ebee2a 100644 (file)
--- a/bytecomp/translobj.ml
+++ b/bytecomp/translobj.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
index 26fa504b4556c78c8d6389e98b77d20c59531c0e..be1e6a90fc5f56431009316ccf7f7477427f3dae 100644 (file)
--- a/bytecomp/translobj.mli
+++ b/bytecomp/translobj.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index f8e43f0df742f7ae2d412c67471569f66e39f745..e80148f0961d76f6368fc13dd718143635f67f4d 100644 (file)
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -37,9 +37,9 @@ let maybe_pointer exp =
       not (Path.same p Predef.path_char) &&
       begin try
         match Env.find_type p exp.exp_env with
-          {type_kind = Type_variant []} -> true (* type exn *)
+        | {type_kind = Type_variant []} -> true (* type exn *)
         | {type_kind = Type_variant cstrs} ->
-            List.exists (fun (name, args) -> args <> []) cstrs
+            List.exists (fun (name, args,_) -> args <> []) cstrs
         | _ -> true
       with Not_found -> true
         (* This can happen due to e.g. missing -I options,
@@ -50,7 +50,7 @@ let maybe_pointer exp =
 
 let array_element_kind env ty =
   match scrape env ty with
-  | Tvar | Tunivar ->
+  | Tvar _ | Tunivar _ ->
       Pgenarray
   | Tconstr(p, args, abbrev) ->
       if Path.same p Predef.path_int || Path.same p Predef.path_char then
@@ -69,7 +69,7 @@ let array_element_kind env ty =
             {type_kind = Type_abstract} ->
               Pgenarray
           | {type_kind = Type_variant cstrs}
-            when List.for_all (fun (name, args) -> args = []) cstrs ->
+            when List.for_all (fun (name, args,_) -> args = []) cstrs ->
               Pintarray
           | {type_kind = _} ->
               Paddrarray

diff --git a/bytecomp/typeopt.mli b/bytecomp/typeopt.mli
index 811c2da37c526e75c8ec35a8f40b04c6a007b92c..163ca44da0f0779e3b086c55cbb6376f712c03e1 100644 (file)
--- a/bytecomp/typeopt.mli
+++ b/bytecomp/typeopt.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/byterun/.cvsignore b/byterun/.cvsignore
deleted file mode 100644 (file)
index 8873b77..0000000
--- a/byterun/.cvsignore
+++ /dev/null
@@ -1,20 +0,0 @@
-jumptbl.h
-primitives
-prims.c
-opnames.h
-version.h
-ocamlrun
-ocamlrund
-ld.conf
-libcamlrun.x
-libcamlrun-gui.x
-*.c.x
-ocamlrun.xcoff
-ocamlrun.dbg
-interp.a.lst
-*.[sd]obj
-*.lib
-.gdb_history
-*.so
-*.a
-.depend.nt

diff --git a/byterun/.depend b/byterun/.depend
index b92cc6de2ac0e687d4ee646b28f3ea4a5d3b0d22..68adc27b321227320b4ad5a402091e3dcd17de7f 100644 (file)
--- a/byterun/.depend
+++ b/byterun/.depend
@@ -6,7 +6,7 @@ array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   minor_gc.h
 backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \
   compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \
-  fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+  exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
   startup.h stacks.h sys.h backtrace.h
 callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \
   ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \
@@ -20,15 +20,15 @@ compare.o: compare.c custom.h compatibility.h mlvalues.h config.h \
 custom.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h
-debugger.o: debugger.c config.h ../config/m.h ../config/s.h \
-  compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \
+debugger.o: debugger.c alloc.h compatibility.h misc.h config.h \
+  ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \
   instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \
   minor_gc.h sys.h
 dynlink.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \
   alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h osdeps.h prims.h
 extern.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \
+  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \
   memory.h major_gc.h freelist.h minor_gc.h reverse.h
 fail.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \
@@ -38,7 +38,8 @@ finalise.o: finalise.c callback.h compatibility.h mlvalues.h config.h \
   major_gc.h freelist.h minor_gc.h signals.h
 fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h \
   compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \
-  md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h
+  intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+  reverse.h
 floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \
   minor_gc.h reverse.h stacks.h
@@ -54,18 +55,18 @@ globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \
   roots.h globroots.h
 hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \
   ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \
-  minor_gc.h
+  minor_gc.h hash.h int64_native.h
 instrtrace.o: instrtrace.c
 intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \
-  memory.h major_gc.h freelist.h minor_gc.h reverse.h
+  ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \
+  md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h
 interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \
   fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \
   memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h
 ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \
-  memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h
+  ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \
+  major_gc.h freelist.h minor_gc.h int64_native.h
 io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
   misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h signals.h sys.h
@@ -142,7 +143,7 @@ array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   minor_gc.h
 backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \
   compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \
-  fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+  exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
   startup.h stacks.h sys.h backtrace.h
 callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \
   ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \
@@ -156,15 +157,15 @@ compare.d.o: compare.c custom.h compatibility.h mlvalues.h config.h \
 custom.d.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h
-debugger.d.o: debugger.c config.h ../config/m.h ../config/s.h \
-  compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \
+debugger.d.o: debugger.c alloc.h compatibility.h misc.h config.h \
+  ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \
   instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \
   minor_gc.h sys.h
 dynlink.d.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \
   alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h osdeps.h prims.h
 extern.d.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \
+  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \
   memory.h major_gc.h freelist.h minor_gc.h reverse.h
 fail.d.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \
@@ -174,7 +175,8 @@ finalise.d.o: finalise.c callback.h compatibility.h mlvalues.h config.h \
   major_gc.h freelist.h minor_gc.h signals.h
 fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h \
   compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \
-  md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h
+  intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+  reverse.h
 floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \
   minor_gc.h reverse.h stacks.h
@@ -190,20 +192,20 @@ globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \
   roots.h globroots.h
 hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \
   ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \
-  minor_gc.h
+  minor_gc.h hash.h int64_native.h
 instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \
   ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \
   memory.h gc.h major_gc.h freelist.h minor_gc.h
 intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \
-  memory.h major_gc.h freelist.h minor_gc.h reverse.h
+  ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \
+  md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h
 interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \
   fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \
   memory.h gc.h minor_gc.h prims.h signals.h stacks.h
 ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \
-  memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h
+  ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \
+  major_gc.h freelist.h minor_gc.h int64_native.h
 io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
   misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h signals.h sys.h
@@ -280,7 +282,7 @@ array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   minor_gc.h
 backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \
   compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \
-  fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+  exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
   startup.h stacks.h sys.h backtrace.h
 callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \
   ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \
@@ -294,15 +296,15 @@ compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \
 custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h
-debugger.pic.o: debugger.c config.h ../config/m.h ../config/s.h \
-  compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \
+debugger.pic.o: debugger.c alloc.h compatibility.h misc.h config.h \
+  ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \
   instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \
   minor_gc.h sys.h
 dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \
   alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h osdeps.h prims.h
 extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \
+  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \
   memory.h major_gc.h freelist.h minor_gc.h reverse.h
 fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \
@@ -312,7 +314,8 @@ finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \
   major_gc.h freelist.h minor_gc.h signals.h
 fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \
   compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \
-  md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h
+  intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
+  reverse.h
 floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \
   minor_gc.h reverse.h stacks.h
@@ -328,18 +331,18 @@ globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \
   roots.h globroots.h
 hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \
   ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \
-  minor_gc.h
+  minor_gc.h hash.h int64_native.h
 instrtrace.pic.o: instrtrace.c
 intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \
-  memory.h major_gc.h freelist.h minor_gc.h reverse.h
+  ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \
+  md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h
 interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \
   ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \
   fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \
   memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h
 ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \
-  ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \
-  memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h
+  ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \
+  major_gc.h freelist.h minor_gc.h int64_native.h
 io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
   misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \
   freelist.h minor_gc.h signals.h sys.h

diff --git a/byterun/.ignore b/byterun/.ignore
new file mode 100644 (file)
index 0000000..59302e0
--- /dev/null
+++ b/byterun/.ignore
@@ -0,0 +1,14 @@
+jumptbl.h
+primitives
+prims.c
+opnames.h
+version.h
+ocamlrun
+ocamlrund
+ld.conf
+interp.a.lst
+*.[sd]obj
+*.lib
+.gdb_history
+*.d.c
+*.pic.c

diff --git a/byterun/Makefile b/byterun/Makefile
index 8ee62aee92fe186f2db7341a36e83865d95f79b7..316f69e5c6d3dc5267a6702e8817a20f13fc6688 100644 (file)
--- a/byterun/Makefile
+++ b/byterun/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -53,20 +53,20 @@ install::
 clean::
        rm -f libcamlrun_shared.so
 
-
 .SUFFIXES: .d.o .pic.o
 
 .c.d.o:
-       @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
-       $(CC) -c $(DFLAGS) $<
-       mv $*.o $*.d.o
-       @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
+       ln -s -f $*.c $*.d.c
+       $(CC) -c $(DFLAGS) $*.d.c
+       rm $*.d.c
 
 .c.pic.o:
-       @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
-       $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $<
-       mv $*.o $*.pic.o
-       @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
+       ln -s -f $*.c $*.pic.c
+       $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $*.pic.c
+       rm $*.pic.c
+
+clean::
+       rm -f *.pic.c *.d.c
 
 depend : prims.c opnames.h jumptbl.h version.h
        -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend

diff --git a/byterun/Makefile.common b/byterun/Makefile.common
index cc75ccede537f19be4c02cc7406b2c170e07347c..7f21fd8d7d3bf444d9e8fa300b1ac59b5f023887 100755 (executable)
--- a/byterun/Makefile.common
+++ b/byterun/Makefile.common
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -33,13 +33,19 @@ PRIMS=\
   dynlink.c backtrace.c
 
 PUBLIC_INCLUDES=\
-  alloc.h callback.h config.h custom.h fail.h intext.h \
+  alloc.h callback.h config.h custom.h fail.h hash.h intext.h \
   memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h
 
 
-all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A)
+all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED)
 .PHONY: all
 
+all-noruntimed:
+.PHONY: all-noruntimed
+
+all-runtimed: ocamlrund$(EXE) libcamlrund.$(A)
+.PHONY: all-runtimed
+
 ld.conf: ../config/Makefile
        echo "$(STUBLIBDIR)" > ld.conf
        echo "$(LIBDIR)" >> ld.conf
@@ -55,6 +61,15 @@ install::
        cp ld.conf $(LIBDIR)/ld.conf
 .PHONY: install
 
+install:: install-$(RUNTIMED)
+
+install-noruntimed:
+.PHONY: install-noruntimed
+
+install-runtimed:
+       cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE)
+       cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A)
+.PHONY: install-runtimed
 
 primitives : $(PRIMS)
        sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \

diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt
index a633787de6c98e7b5474322201597de05e4106f9..b93fa58a8576c4acbc04de7ae8c0bb194cf9d909 100644 (file)
--- a/byterun/Makefile.nt
+++ b/byterun/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/byterun/alloc.c b/byterun/alloc.c
index cc19698a8fa2e601d5a68b5fddf3ad2aab3fea45..034562e8ea2ccdda9fbf24925f894d4dafd5c474 100644 (file)
--- a/byterun/alloc.c
+++ b/byterun/alloc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/alloc.h b/byterun/alloc.h
index 66cab702444a3cc77848c39d6603f30d5d3cbdff..75dd5ec8f9dd39bc136894d03043d9ab638b6008 100644 (file)
--- a/byterun/alloc.h
+++ b/byterun/alloc.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -23,6 +23,10 @@
 #include "misc.h"
 #include "mlvalues.h"
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 CAMLextern value caml_alloc (mlsize_t, tag_t);
 CAMLextern value caml_alloc_small (mlsize_t, tag_t);
 CAMLextern value caml_alloc_tuple (mlsize_t);
@@ -44,4 +48,8 @@ CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/
 
 CAMLextern int caml_convert_flag_list (value, int *);
 
+#ifdef __cplusplus
+}
+#endif
+
 #endif /* CAML_ALLOC_H */

diff --git a/byterun/array.c b/byterun/array.c
index fc60659523ea8d2f4c18f68bfa3aabd56ab67161..637fe9c8048e2fd4fa63317110a16f92279c78aa 100644 (file)
--- a/byterun/array.c
+++ b/byterun/array.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                           OCaml                                     */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -15,12 +15,26 @@
 
 /* Operations on arrays */
 
+#include <string.h>
 #include "alloc.h"
 #include "fail.h"
 #include "memory.h"
 #include "misc.h"
 #include "mlvalues.h"
 
+CAMLexport mlsize_t caml_array_length(value array)
+{
+  if (Tag_val(array) == Double_array_tag)
+    return Wosize_val(array) / Double_wosize;
+  else
+    return Wosize_val(array);
+}
+
+CAMLexport int caml_is_double_array(value array)
+{
+  return (Tag_val(array) == Double_array_tag);
+}
+
 CAMLprim value caml_array_get_addr(value array, value index)
 {
   intnat idx = Long_val(index);
@@ -191,3 +205,181 @@ CAMLprim value caml_make_array(value init)
     }
   }
 }
+
+/* Blitting */
+
+CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2,
+                               value n)
+{
+  value * src, * dst;
+  intnat count;
+
+  if (Tag_val(a2) == Double_array_tag) {
+    /* Arrays of floats.  The values being copied are floats, not
+       pointer, so we can do a direct copy.  memmove takes care of
+       potential overlap between the copied areas. */
+    memmove((double *)a2 + Long_val(ofs2),
+            (double *)a1 + Long_val(ofs1),
+            Long_val(n) * sizeof(double));
+    return Val_unit;
+  }
+  if (Is_young(a2)) {
+    /* Arrays of values, destination is in young generation.
+       Here too we can do a direct copy since this cannot create
+       old-to-young pointers, nor mess up with the incremental major GC.
+       Again, memmove takes care of overlap. */
+    memmove(&Field(a2, Long_val(ofs2)),
+            &Field(a1, Long_val(ofs1)),
+            Long_val(n) * sizeof(value));
+    return Val_unit;
+  }
+  /* Array of values, destination is in old generation.
+     We must use caml_modify.  */
+  count = Long_val(n);
+  if (a1 == a2 && Long_val(ofs1) < Long_val(ofs2)) {
+    /* Copy in descending order */
+    for (dst = &Field(a2, Long_val(ofs2) + count - 1),
+           src = &Field(a1, Long_val(ofs1) + count - 1);
+         count > 0;
+         count--, src--, dst--) {
+      caml_modify(dst, *src);
+    }
+  } else {
+    /* Copy in ascending order */
+    for (dst = &Field(a2, Long_val(ofs2)), src = &Field(a1, Long_val(ofs1));
+         count > 0;
+         count--, src++, dst++) {
+      caml_modify(dst, *src);
+    }
+  }
+  /* Many caml_modify in a row can create a lot of old-to-young refs.
+     Give the minor GC a chance to run if it needs to. */
+  caml_check_urgent_gc(Val_unit);
+  return Val_unit;
+}
+
+/* A generic function for extraction and concatenation of sub-arrays */
+
+static value caml_array_gather(intnat num_arrays,
+                               value arrays[/*num_arrays*/],
+                               intnat offsets[/*num_arrays*/],
+                               intnat lengths[/*num_arrays*/])
+{
+  CAMLparamN(arrays, num_arrays);
+  value res;                    /* no need to register it as a root */
+  int isfloat;
+  mlsize_t i, size, wsize, count, pos;
+  value * src;
+
+  /* Determine total size and whether result array is an array of floats */
+  size = 0;
+  isfloat = 0;
+  for (i = 0; i < num_arrays; i++) {
+    size += lengths[i];
+    if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1;
+  }
+  if (size == 0) {
+    /* If total size = 0, just return empty array */
+    res = Atom(0);
+  }
+  else if (isfloat) {
+    /* This is an array of floats.  We can use memcpy directly. */
+    wsize = size * Double_wosize;
+    if (wsize > Max_wosize) caml_invalid_argument("Array.concat");
+    res = caml_alloc(wsize, Double_array_tag);
+    for (i = 0, pos = 0; i < num_arrays; i++) {
+      memcpy((double *)res + pos,
+             (double *)arrays[i] + offsets[i],
+             lengths[i] * sizeof(double));
+      pos += lengths[i];
+    }
+    Assert(pos == size);
+  }
+  else if (size > Max_wosize) {
+    /* Array of values, too big. */
+    caml_invalid_argument("Array.concat");
+  }
+  else if (size < Max_young_wosize) {
+    /* Array of values, small enough to fit in young generation.
+       We can use memcpy directly. */
+    res = caml_alloc_small(size, 0);
+    for (i = 0, pos = 0; i < num_arrays; i++) {
+      memcpy(&Field(res, pos),
+             &Field(arrays[i], offsets[i]),
+             lengths[i] * sizeof(value));
+      pos += lengths[i];
+    }
+    Assert(pos == size);
+  } else {
+    /* Array of values, must be allocated in old generation and filled
+       using caml_initialize. */
+    res = caml_alloc_shr(size, 0);
+    pos = 0;
+    for (i = 0, pos = 0; i < num_arrays; i++) {
+      for (src = &Field(arrays[i], offsets[i]), count = lengths[i];
+           count > 0;
+           count--, src++, pos++) {
+        caml_initialize(&Field(res, pos), *src);
+      }
+      /* Many caml_initialize in a row can create a lot of old-to-young
+         refs.  Give the minor GC a chance to run if it needs to. */
+      res = caml_check_urgent_gc(res);
+    }
+    Assert(pos == size);
+  }
+  CAMLreturn (res);
+}
+
+CAMLprim value caml_array_sub(value a, value ofs, value len)
+{
+  value arrays[1] = { a };
+  intnat offsets[1] = { Long_val(ofs) };
+  intnat lengths[1] = { Long_val(len) };
+  return caml_array_gather(1, arrays, offsets, lengths);
+}
+
+CAMLprim value caml_array_append(value a1, value a2)
+{
+  value arrays[2] = { a1, a2 };
+  intnat offsets[2] = { 0, 0 };
+  intnat lengths[2] = { caml_array_length(a1), caml_array_length(a2) };
+  return caml_array_gather(2, arrays, offsets, lengths);
+}
+
+CAMLprim value caml_array_concat(value al)
+{
+#define STATIC_SIZE 16
+  value static_arrays[STATIC_SIZE], * arrays;
+  intnat static_offsets[STATIC_SIZE], * offsets;
+  intnat static_lengths[STATIC_SIZE], * lengths;
+  intnat n, i;
+  value l, res;
+
+  /* Length of list = number of arrays */
+  for (n = 0, l = al; l != Val_int(0); l = Field(l, 1)) n++;
+  /* Allocate extra storage if too many arrays */
+  if (n <= STATIC_SIZE) {
+    arrays = static_arrays;
+    offsets = static_offsets;
+    lengths = static_lengths;
+  } else {
+    arrays = caml_stat_alloc(n * sizeof(value));
+    offsets = caml_stat_alloc(n * sizeof(intnat));
+    lengths = caml_stat_alloc(n * sizeof(value));
+  }
+  /* Build the parameters to caml_array_gather */
+  for (i = 0, l = al; l != Val_int(0); l = Field(l, 1), i++) {
+    arrays[i] = Field(l, 0);
+    offsets[i] = 0;
+    lengths[i] = caml_array_length(Field(l, 0));
+  }
+  /* Do the concatenation */
+  res = caml_array_gather(n, arrays, offsets, lengths);
+  /* Free the extra storage if needed */
+  if (n > STATIC_SIZE) {
+    caml_stat_free(arrays);
+    caml_stat_free(offsets);
+    caml_stat_free(lengths);
+  }
+  return res;
+}

diff --git a/byterun/backtrace.c b/byterun/backtrace.c
index 2b29c31dcc49b81c0ef7d319b03eeb8dc160c76e..b5efdc3db6d3217c4e9548a4cbb42d9ab18052cf 100644 (file)
--- a/byterun/backtrace.c
+++ b/byterun/backtrace.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -118,7 +118,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp)
 }
 
 /* Read the debugging info contained in the current bytecode executable.
-   Return a Caml array of Caml lists of debug_event records in "events",
+   Return an OCaml array of OCaml lists of debug_event records in "events",
    or Val_false on failure. */
 
 #ifndef O_BINARY
@@ -274,7 +274,7 @@ CAMLexport void caml_print_exception_backtrace(void)
   }
 }
 
-/* Convert the backtrace to a data structure usable from Caml */
+/* Convert the backtrace to a data structure usable from OCaml */
 
 CAMLprim value caml_get_exception_backtrace(value unit)
 {

diff --git a/byterun/backtrace.h b/byterun/backtrace.h
index 2d9c202eaacf407982fbeb6108a4b583c64598f8..23c72e6c9408f454a533dba14788d1475db836b6 100644 (file)
--- a/byterun/backtrace.h
+++ b/byterun/backtrace.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/callback.c b/byterun/callback.c
index d76cf108bf5735a31ca7d63fc98229fcc553afa8..c7fc77220864e22bbb482753407eec2b23643ee8 100644 (file)
--- a/byterun/callback.c
+++ b/byterun/callback.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -13,7 +13,7 @@
 
 /* $Id$ */
 
-/* Callbacks from C to Caml */
+/* Callbacks from C to OCaml */
 
 #include <string.h>
 #include "callback.h"
@@ -195,7 +195,7 @@ CAMLexport value caml_callbackN (value closure, int narg, value args[])
   return res;
 }
 
-/* Naming of Caml values */
+/* Naming of OCaml values */
 
 struct named_value {
   value val;

diff --git a/byterun/callback.h b/byterun/callback.h
index ffa6cf3b5ece8be6f3ace0b706a910f30332bdf8..dd094c4dec7134ad28e3446178a43f3bc28edc67 100644 (file)
--- a/byterun/callback.h
+++ b/byterun/callback.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -13,7 +13,7 @@
 
 /* $Id$ */
 
-/* Callbacks from C to Caml */
+/* Callbacks from C to OCaml */
 
 #ifndef CAML_CALLBACK_H
 #define CAML_CALLBACK_H
@@ -23,6 +23,10 @@
 #endif
 #include "mlvalues.h"
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 CAMLextern value caml_callback (value closure, value arg);
 CAMLextern value caml_callback2 (value closure, value arg1, value arg2);
 CAMLextern value caml_callback3 (value closure, value arg1, value arg2,
@@ -46,4 +50,8 @@ CAMLextern void caml_startup (char ** argv);
 
 CAMLextern int caml_callback_depth;
 
+#ifdef __cplusplus
+}
+#endif
+
 #endif

diff --git a/byterun/compact.c b/byterun/compact.c
index ba1042fbe50bfba98fa6ee13bf32c003680294c4..b3c75f3389c538f1b7a578e4bcc20f26135ca462 100644 (file)
--- a/byterun/compact.c
+++ b/byterun/compact.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */
@@ -144,7 +144,7 @@ static char *compact_allocate (mlsize_t size)
   return adr;
 }
 
-void caml_compact_heap (void)
+static void do_compaction (void)
 {
   char *ch, *chend;
                                           Assert (caml_gc_phase == Phase_idle);
@@ -395,6 +395,58 @@ void caml_compact_heap (void)
 
 uintnat caml_percent_max;  /* used in gc_ctrl.c and memory.c */
 
+void caml_compact_heap (void)
+{
+  uintnat target_size;
+
+  do_compaction ();
+  /* Compaction may fail to shrink the heap to a reasonable size
+     because it deals in complete chunks: if a very large chunk
+     is at the beginning of the heap, everything gets moved to
+     it and it is not freed.
+
+     In that case, we allocate a new chunk of the desired heap
+     size, chain it at the beginning of the heap (thus pretending
+     its address is smaller), and launch a second compaction.
+     This will move all data to this new chunk and free the
+     very large chunk.
+
+     See PR#5389
+  */
+  /* We compute:
+     freewords = caml_fl_cur_size          (exact)
+     heapsize = caml_heap_size             (exact)
+     usedwords = heap_size - freewords
+     target_size = usedwords * (1 + caml_percent_free / 100)
+
+     We recompact if target_size < heap_size / 2
+  */
+  target_size = (caml_stat_heap_size - Bsize_wsize (caml_fl_cur_size))
+                * (100 + caml_percent_free) / 100;
+  target_size = caml_round_heap_chunk_size (target_size);
+  if (target_size < caml_stat_heap_size / 2){
+    char *chunk;
+
+    /* round it up to a page size */
+    chunk = caml_alloc_for_heap (target_size);
+    if (chunk == NULL) return;
+    caml_make_free_blocks ((value *) chunk,
+                           Wsize_bsize (Chunk_size (chunk)), 0);
+    if (caml_page_table_add (In_heap, chunk, chunk + Chunk_size (chunk)) != 0){
+      caml_free_for_heap (chunk);
+      return;
+    }
+    Chunk_next (chunk) = caml_heap_start;
+    caml_heap_start = chunk;
+    caml_stat_heap_size += Chunk_size (chunk);
+    if (caml_stat_heap_size > caml_stat_top_heap_size){
+      caml_stat_top_heap_size = caml_stat_heap_size;
+    }
+    do_compaction ();
+    Assert (Chunk_next (caml_heap_start) == NULL);
+  }
+}
+
 void caml_compact_heap_maybe (void)
 {
   /* Estimated free words in the heap:
@@ -408,7 +460,7 @@ void caml_compact_heap_maybe (void)
   float fw, fp;
                                           Assert (caml_gc_phase == Phase_idle);
   if (caml_percent_max >= 1000000) return;
-  if (caml_stat_major_collections < 3 || caml_stat_heap_chunks < 3) return;
+  if (caml_stat_major_collections < 3) return;
 
   fw = 3.0 * caml_fl_cur_size - 2.0 * caml_fl_size_at_phase_change;
   if (fw < 0) fw = caml_fl_cur_size;

diff --git a/byterun/compact.h b/byterun/compact.h
index a4ef4cb186005ccfa1e3641c120b30b412f7e118..949a2766ed3d83b24ad9795c2e10d9d1aacfaf95 100644 (file)
--- a/byterun/compact.h
+++ b/byterun/compact.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/compare.c b/byterun/compare.c
index 751630757b862b8301d6e1951fe8b50adedce539..c0ee65a2609511d7c50efd970f56d445df96fdb1 100644 (file)
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -106,7 +106,7 @@ static intnat compare_val(value v1, value v2, int total)
       /* Subtraction above cannot overflow and cannot result in UNORDERED */
       if (Is_in_value_area(v2)) {
         switch (Tag_val(v2)) {
-        case Forward_tag: 
+        case Forward_tag:
           v2 = Forward_val(v2);
           continue;
         case Custom_tag: {

diff --git a/byterun/compare.h b/byterun/compare.h
index dc392ff3de32d082f4e07042b36a56ff6198ffc9..c73a49a46f0875d85c74429d6e2958f8a9547896 100644 (file)
--- a/byterun/compare.h
+++ b/byterun/compare.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*          Damien Doligez, Projet Moscova, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/compatibility.h b/byterun/compatibility.h
index 5c21774e060f4d83fdf00725271667d7a07d8b2b..429d2275d7add1154bf4ef941754c3fca9bcca3b 100644 (file)
--- a/byterun/compatibility.h
+++ b/byterun/compatibility.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*          Damien Doligez, projet Moscova, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/config.h b/byterun/config.h
index 22abe871d446f04040c6a3b58c001ab8aab27502..b36b73c9554f642afd37f3db6a54ca07e3c900c1 100644 (file)
--- a/byterun/config.h
+++ b/byterun/config.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/custom.c b/byterun/custom.c
index 24281db84bbbabf4fb77778d4b1b4665e1073aeb..b2d7b52065d61bdc0f0102011e817a8bf3c57fa0 100644 (file)
--- a/byterun/custom.c
+++ b/byterun/custom.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/custom.h b/byterun/custom.h
index 51fabed9da8863b497ec3ab59f72d47cfded60f3..c6abad8ef058a84a2e6547f450628f7a18e2b2e3 100644 (file)
--- a/byterun/custom.h
+++ b/byterun/custom.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -43,6 +43,11 @@ struct custom_operations {
 
 #define Custom_ops_val(v) (*((struct custom_operations **) (v)))
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
 CAMLextern value caml_alloc_custom(struct custom_operations * ops,
                                    uintnat size, /*size in bytes*/
                                    mlsize_t mem, /*resources consumed*/
@@ -61,4 +66,8 @@ extern struct custom_operations *
 extern void caml_init_custom_operations(void);
 /* </private> */
 
+#ifdef __cplusplus
+}
+#endif
+
 #endif /* CAML_CUSTOM_H */

diff --git a/byterun/debugger.c b/byterun/debugger.c
index f9689126a650ec38b60463ef353666cf4e03b29b..a114b46cbc5d0d477346e76e00975501e9903acf 100644 (file)
--- a/byterun/debugger.c
+++ b/byterun/debugger.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -21,6 +21,7 @@
 
 #include <string.h>
 
+#include "alloc.h"
 #include "config.h"
 #include "debugger.h"
 #include "misc.h"
@@ -28,6 +29,7 @@
 int caml_debugger_in_use = 0;
 uintnat caml_event_count;
 int caml_debugger_fork_mode = 1; /* parent by default */
+value marshal_flags = Val_emptylist;
 
 #if !defined(HAS_SOCKETS) || defined(NATIVE_CODE)
 
@@ -162,6 +164,11 @@ void caml_debugger_init(void)
   struct hostent * host;
   int n;
 
+  caml_register_global_root(&marshal_flags);
+  marshal_flags = caml_alloc(2, Tag_cons);
+  Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */
+  Store_field(marshal_flags, 1, Val_emptylist);
+
   address = getenv("CAML_DEBUG_SOCKET");
   if (address == NULL) return;
   dbg_addr = address;
@@ -230,7 +237,7 @@ static void safe_output_value(struct channel *chan, value val)
   saved_external_raise = caml_external_raise;
   if (sigsetjmp(raise_buf.buf, 0) == 0) {
     caml_external_raise = &raise_buf;
-    caml_output_val(chan, val, Val_unit);
+    caml_output_val(chan, val, marshal_flags);
   } else {
     /* Send wrong magic number, will cause [caml_input_value] to fail */
     caml_really_putblock(chan, "\000\000\000\000", 4);

diff --git a/byterun/debugger.h b/byterun/debugger.h
index 57a58f1c6da96bf5ba868fae782db58aabd13fb2..a9501abff10216a7661d80df8c8be83dd5074a63 100644 (file)
--- a/byterun/debugger.h
+++ b/byterun/debugger.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/dynlink.c b/byterun/dynlink.c
index 7df594dbe91c7b6e7e3eaea40b5ef98aed1fb45c..ddd406babfa3139cbc3b6a6115c8f2802e139897 100644 (file)
--- a/byterun/dynlink.c
+++ b/byterun/dynlink.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/dynlink.h b/byterun/dynlink.h
index ad4bfbadbacf39a90b86f5e376759405622066a0..b1d14d844f9df6846bbbbdba223cea45766ef548 100644 (file)
--- a/byterun/dynlink.h
+++ b/byterun/dynlink.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/exec.h b/byterun/exec.h
index 1abfa455c3ee84ee4aaeadedb991104dd6f72d75..88cf6d28b7036158954908526e0c5e9ffa0f96cd 100644 (file)
--- a/byterun/exec.h
+++ b/byterun/exec.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/extern.c b/byterun/extern.c
index 89e89f00e47618ad4a64ad8148db32a3d5eb55b0..b95a5054062e075bd786fa539959e0e5b833dba4 100644 (file)
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -24,6 +24,7 @@
 #include "gc.h"
 #include "intext.h"
 #include "io.h"
+#include "md5.h"
 #include "memory.h"
 #include "misc.h"
 #include "mlvalues.h"
@@ -56,6 +57,7 @@ static struct trail_entry * extern_trail_cur, * extern_trail_limit;
 
 static void extern_out_of_memory(void);
 static void extern_invalid_argument(char *msg);
+static struct code_fragment * extern_find_code(char *addr);
 
 /* Initialize the trail */
 
@@ -289,6 +291,7 @@ static void writecode64(int code, intnat val)
 
 static void extern_rec(value v)
 {
+  struct code_fragment * cf;
  tailcall:
   if (Is_long(v)) {
     intnat n = Long_val(v);
@@ -438,12 +441,11 @@ static void extern_rec(value v)
     }
     }
   }
-  else if ((char *) v >= caml_code_area_start &&
-           (char *) v < caml_code_area_end) {
+  else if ((cf = extern_find_code((char *) v)) != NULL) {
     if (!extern_closures)
       extern_invalid_argument("output_value: functional value");
-    writecode32(CODE_CODEPOINTER, (char *) v - caml_code_area_start);
-    writeblock((char *) caml_code_checksum(), 16);
+    writecode32(CODE_CODEPOINTER, (char *) v - cf->code_start);
+    writeblock((char *) cf->digest, 16);
   } else {
     extern_invalid_argument("output_value: abstract value (outside heap)");
   }
@@ -724,3 +726,20 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len)
   }
 #endif
 }
+
+/* Find where a code pointer comes from */
+
+static struct code_fragment * extern_find_code(char *addr)
+{
+  int i;
+  for (i = caml_code_fragments_table.size - 1; i >= 0; i--) {
+    struct code_fragment * cf = caml_code_fragments_table.contents[i];
+    if (! cf->digest_computed) {
+      caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start);
+      cf->digest_computed = 1;
+    }
+    if (cf->code_start <= addr && addr < cf->code_end) return cf;
+  }
+  return NULL;
+}
+

diff --git a/byterun/fail.c b/byterun/fail.c
index aceb253b9da53d059334bcb8146420495299292c..b0beaa437a2329044549d6b65c16245ab72ba0af 100644 (file)
--- a/byterun/fail.c
+++ b/byterun/fail.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -168,3 +168,9 @@ void caml_init_exceptions(void)
   out_of_memory_bucket.exn = Field(caml_global_data, OUT_OF_MEMORY_EXN);
   caml_register_global_root(&out_of_memory_bucket.exn);
 }
+
+int caml_is_special_exception(value exn) {
+  return exn == Field(caml_global_data, MATCH_FAILURE_EXN)
+    || exn == Field(caml_global_data, ASSERT_FAILURE_EXN)
+    || exn == Field(caml_global_data, UNDEFINED_RECURSIVE_MODULE_EXN);
+}

diff --git a/byterun/fail.h b/byterun/fail.h
index f092c8115f0845cad53f1b8e8fd7cf50e828b6af..ee05eb7f8a50012ed9197b8717305ccc1bdf5a00 100644 (file)
--- a/byterun/fail.h
+++ b/byterun/fail.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -54,9 +54,14 @@ struct longjmp_buffer {
 
 CAMLextern struct longjmp_buffer * caml_external_raise;
 extern value caml_exn_bucket;
+int caml_is_special_exception(value exn);
 
 /* </private> */
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 CAMLextern void caml_raise (value bucket) Noreturn;
 CAMLextern void caml_raise_constant (value tag) Noreturn;
 CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn;
@@ -74,4 +79,8 @@ CAMLextern void caml_init_exceptions (void);
 CAMLextern void caml_array_bound_error (void) Noreturn;
 CAMLextern void caml_raise_sys_blocked_io (void) Noreturn;
 
+#ifdef __cplusplus
+}
+#endif
+
 #endif /* CAML_FAIL_H */

diff --git a/byterun/finalise.c b/byterun/finalise.c
index bc7996d550f384563435bed0467a542c70e928ed..9a93084ae4aaf985950574001f8c698f5fc4bf91 100644 (file)
--- a/byterun/finalise.c
+++ b/byterun/finalise.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*          Damien Doligez, projet Moscova, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/finalise.h b/byterun/finalise.h
index ec656f4f48df22ac63f68cb4b9fb92ca7414c70a..e41baa320c8bfa53fc26458071365437db5c09c6 100644 (file)
--- a/byterun/finalise.h
+++ b/byterun/finalise.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*          Damien Doligez, projet Moscova, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/fix_code.c b/byterun/fix_code.c
index b252efd587a43f7a40e2075579f1b9b6bdbaed38..27e715be1f81c18bb0019ee1b8b9b1e423630d0c 100644 (file)
--- a/byterun/fix_code.c
+++ b/byterun/fix_code.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -24,6 +24,7 @@
 #include "debugger.h"
 #include "fix_code.h"
 #include "instruct.h"
+#include "intext.h"
 #include "md5.h"
 #include "memory.h"
 #include "misc.h"
@@ -40,15 +41,21 @@ unsigned char caml_code_md5[16];
 void caml_load_code(int fd, asize_t len)
 {
   int i;
-  struct MD5Context ctx;
+  struct code_fragment * cf;
 
   caml_code_size = len;
   caml_start_code = (code_t) caml_stat_alloc(caml_code_size);
   if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size)
     caml_fatal_error("Fatal error: truncated bytecode file.\n");
-  caml_MD5Init(&ctx);
-  caml_MD5Update(&ctx, (unsigned char *) caml_start_code, caml_code_size);
-  caml_MD5Final(caml_code_md5, &ctx);
+  /* Register the code in the table of code fragments */
+  cf = caml_stat_alloc(sizeof(struct code_fragment));
+  cf->code_start = (char *) caml_start_code;
+  cf->code_end = (char *) caml_start_code + caml_code_size;
+  caml_md5_block(cf->digest, caml_start_code, caml_code_size);
+  cf->digest_computed = 1;
+  caml_ext_table_init(&caml_code_fragments_table, 8);
+  caml_ext_table_add(&caml_code_fragments_table, cf);
+  /* Prepare the code for execution */
 #ifdef ARCH_BIG_ENDIAN
   caml_fixup_endianness(caml_start_code, caml_code_size);
 #endif

diff --git a/byterun/fix_code.h b/byterun/fix_code.h
index f6e9e3b7730959f2e543be133ecbcfaf81915429..d0887c038558501fdc5debca2b9c521b475767db 100644 (file)
--- a/byterun/fix_code.h
+++ b/byterun/fix_code.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -26,7 +26,6 @@
 extern code_t caml_start_code;
 extern asize_t caml_code_size;
 extern unsigned char * caml_saved_code;
-extern unsigned char caml_code_md5[16];
 
 void caml_load_code (int fd, asize_t len);
 void caml_fixup_endianness (code_t code, asize_t len);

diff --git a/byterun/floats.c b/byterun/floats.c
index d1d178a329010ab07ad38039c3edb3cb277853a0..f708d70f70ab4b07efd1745035f7a47d7836ad1f 100644 (file)
--- a/byterun/floats.c
+++ b/byterun/floats.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -28,6 +28,12 @@
 #include "reverse.h"
 #include "stacks.h"
 
+#ifdef _MSC_VER
+#include <float.h>
+#define isnan _isnan
+#define isfinite _finite
+#endif
+
 #ifdef ARCH_ALIGN_DOUBLE
 
 CAMLexport double caml_Double_val(value val)
@@ -77,7 +83,11 @@ CAMLprim value caml_format_float(value fmt, value arg)
   char * p;
   char * dest;
   value res;
+  double d = Double_val(arg);
 
+#ifdef HAS_BROKEN_PRINTF
+  if (isfinite(d)) {
+#endif
   prec = MAX_DIGITS;
   for (p = String_val(fmt); *p != 0; p++) {
     if (*p >= '0' && *p <= '9') {
@@ -98,11 +108,30 @@ CAMLprim value caml_format_float(value fmt, value arg)
   } else {
     dest = caml_stat_alloc(prec);
   }
-  sprintf(dest, String_val(fmt), Double_val(arg));
+  sprintf(dest, String_val(fmt), d);
   res = caml_copy_string(dest);
   if (dest != format_buffer) {
     caml_stat_free(dest);
   }
+#ifdef HAS_BROKEN_PRINTF
+  } else {
+    if (isnan(d))
+    {
+      res = caml_copy_string("nan");
+    }
+    else
+    {
+      if (d > 0)
+      {
+        res = caml_copy_string("inf");
+      }
+      else
+      {
+        res = caml_copy_string("-inf");
+      }
+    }
+  }
+#endif
   return res;
 }
 
@@ -326,12 +355,32 @@ CAMLprim value caml_ceil_float(value f)
   return caml_copy_double(ceil(Double_val(f)));
 }
 
+CAMLexport double caml_hypot(double x, double y)
+{
+#ifdef HAS_C99_FLOAT_OPS
+  return hypot(x, y);
+#else
+  double tmp, ratio;
+  if (x != x) return x;  /* NaN */
+  if (y != y) return y;  /* NaN */
+  x = fabs(x); y = fabs(y);
+  if (x < y) { tmp = x; x = y; y = tmp; }
+  if (x == 0.0) return 0.0;
+  ratio = y / x;
+  return x * sqrt(1.0 + ratio * ratio);
+#endif
+}
+
+CAMLprim value caml_hypot_float(value f, value g)
+{
+  return caml_copy_double(caml_hypot(Double_val(f), Double_val(g)));
+}
+
 /* These emulations of expm1() and log1p() are due to William Kahan.
    See http://www.plunk.org/~hatch/rightway.php */
-
 CAMLexport double caml_expm1(double x)
 {
-#ifdef HAS_EXPM1_LOG1P
+#ifdef HAS_C99_FLOAT_OPS
   return expm1(x);
 #else
   double u = exp(x);
@@ -345,7 +394,7 @@ CAMLexport double caml_expm1(double x)
 
 CAMLexport double caml_log1p(double x)
 {
-#ifdef HAS_EXPM1_LOG1P
+#ifdef HAS_C99_FLOAT_OPS
   return log1p(x);
 #else
   double u = 1. + x;
@@ -366,6 +415,34 @@ CAMLprim value caml_log1p_float(value f)
   return caml_copy_double(caml_log1p(Double_val(f)));
 }
 
+union double_as_two_int32 {
+    double d;
+#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__))
+    struct { uint32 h; uint32 l; } i;
+#else
+    struct { uint32 l; uint32 h; } i;
+#endif
+};
+
+CAMLexport double caml_copysign(double x, double y)
+{
+#ifdef HAS_C99_FLOAT_OPS
+  return copysign(x, y);
+#else
+  union double_as_two_int32 ux, uy;
+  ux.d = x;
+  uy.d = y;
+  ux.i.h &= 0x7FFFFFFFU;
+  ux.i.h |= (uy.i.h & 0x80000000U);
+  return ux.d;
+#endif
+}
+
+CAMLprim value caml_copysign_float(value f, value g)
+{
+  return caml_copy_double(caml_copysign(Double_val(f), Double_val(g)));
+}
+
 CAMLprim value caml_eq_float(value f, value g)
 {
   return Val_bool(Double_val(f) == Double_val(g));
@@ -429,14 +506,7 @@ CAMLprim value caml_classify_float(value vd)
     return Val_int(FP_normal);
   }
 #else
-  union {
-    double d;
-#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__))
-    struct { uint32 h; uint32 l; } i;
-#else
-    struct { uint32 l; uint32 h; } i;
-#endif
-  } u;
+  union double_as_two_int32 u;
   uint32 h, l;
 
   u.d = Double_val(vd);

diff --git a/byterun/freelist.c b/byterun/freelist.c
index ab1d458ba249af3f9ed30d9669d8fbee3480f597..f3bb4a8ee06ba55b39902b9b1975cc6375371781 100644 (file)
--- a/byterun/freelist.c
+++ b/byterun/freelist.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/freelist.h b/byterun/freelist.h
index 8db168e9b5342368040eb9ce74692b6b306af1c2..b4285d9556d970ef68726bab7d00c17ea5eee6f5 100644 (file)
--- a/byterun/freelist.h
+++ b/byterun/freelist.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/gc.h b/byterun/gc.h
index 50d9945a8d610f0ed3f7dd3753dde6f9b907b033..4f67ed9066619e072e3ac81695233275acbdc949 100644 (file)
--- a/byterun/gc.h
+++ b/byterun/gc.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
index 9a2e0b08cad5edb512e78d2065b95856b1731f21..b5c4366798ba7f82305b0c3a299e64db3f349b66 100644 (file)
--- a/byterun/gc_ctrl.c
+++ b/byterun/gc_ctrl.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */
@@ -133,7 +133,7 @@ static value heap_stats (int returnstats)
   header_t cur_hd;
 
 #ifdef DEBUG
-  caml_gc_message (-1, "### O'Caml runtime: heap check ###\n", 0);
+  caml_gc_message (-1, "### OCaml runtime: heap check ###\n", 0);
 #endif
 
   while (chunk != NULL){

diff --git a/byterun/gc_ctrl.h b/byterun/gc_ctrl.h
index 205636d5901ebb05e7dd781062608eca2c6a0d0a..4dba74fa57e458114343bc2d2b0135e15f3fcca5 100644 (file)
--- a/byterun/gc_ctrl.h
+++ b/byterun/gc_ctrl.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/globroots.c b/byterun/globroots.c
index acac1e2170baeebec2990ce427e10a90c7f91299..513b7be553dd6e001690c9eee848a2c6ae96e32d 100644 (file)
--- a/byterun/globroots.c
+++ b/byterun/globroots.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
 /*                                                                     */

diff --git a/byterun/globroots.h b/byterun/globroots.h
index 4dee35f23be00eccb26a41ac5bc956dcd4eb9534..97a1edab1591dd65a2322b0c0098b5f1e2b8f78e 100644 (file)
--- a/byterun/globroots.h
+++ b/byterun/globroots.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
 /*                                                                     */

diff --git a/byterun/hash.c b/byterun/hash.c
index c981768d0ff29def004c73cba632aa533d3873d3..26a1bf5979e2c07716a02b32be209d2d8ef317ea 100644 (file)
--- a/byterun/hash.c
+++ b/byterun/hash.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -15,11 +15,267 @@
 
 /* The generic hashing primitive */
 
-/* The interface of this file is in "mlvalues.h" */
+/* The interface of this file is in "mlvalues.h" (for [caml_hash_variant])
+   and in "hash.h" (for the other exported functions). */
 
 #include "mlvalues.h"
 #include "custom.h"
 #include "memory.h"
+#include "hash.h"
+
+#ifdef ARCH_INT64_TYPE
+#include "int64_native.h"
+#else
+#include "int64_emul.h"
+#endif
+
+/* The new implementation, based on MurmurHash 3,
+     http://code.google.com/p/smhasher/  */
+
+#define ROTL32(x,n) ((x) << n | (x) >> (32-n))
+
+#define MIX(h,d) \
+  d *= 0xcc9e2d51; \
+  d = ROTL32(d, 15); \
+  d *= 0x1b873593; \
+  h ^= d; \
+  h = ROTL32(h, 13); \
+  h = h * 5 + 0xe6546b64;
+
+#define FINAL_MIX(h) \
+  h ^= h >> 16; \
+  h *= 0x85ebca6b; \
+  h ^= h >> 13; \
+  h *= 0xc2b2ae35; \
+  h ^= h >> 16;
+
+CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d)
+{
+  MIX(h, d);
+  return h;
+}
+
+/* Mix a platform-native integer. */
+
+CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d)
+{
+  uint32 n;
+#ifdef ARCH_SIXTYFOUR
+  /* Mix the low 32 bits and the high 32 bits, in a way that preserves
+     32/64 compatibility: we want n = (uint32) d
+     if d is in the range [-2^31, 2^31-1]. */
+  n = (d >> 32) ^ (d >> 63) ^ d;
+  /* If 0 <= d < 2^31:   d >> 32 = 0     d >> 63 = 0
+     If -2^31 <= d < 0:  d >> 32 = -1    d >> 63 = -1
+     In both cases, n = (uint32) d.  */
+#else
+  n = d;
+#endif
+  MIX(h, n);
+  return h;
+}
+
+/* Mix a 64-bit integer. */
+
+CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d)
+{
+  uint32 hi, lo;
+
+  I64_split(d, hi, lo);
+  MIX(h, lo);
+  MIX(h, hi);
+  return h;
+}
+
+/* Mix a double-precision float.
+   Treats +0.0 and -0.0 identically.
+   Treats all NaNs identically.
+*/
+
+CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d)
+{
+  union {
+    double d;
+#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__))
+    struct { uint32 h; uint32 l; } i;
+#else
+    struct { uint32 l; uint32 h; } i;
+#endif
+  } u;
+  uint32 h, l;
+  /* Convert to two 32-bit halves */
+  u.d = d;
+  h = u.i.h; l = u.i.l;
+  /* Normalize NaNs */
+  if ((h & 0x7FF00000) == 0x7FF00000 && (l | (h & 0xFFFFF)) != 0) {
+    h = 0x7FF00000;
+    l = 0x00000001;
+  }
+  /* Normalize -0 into +0 */
+  else if (h == 0x80000000 && l == 0) {
+    h = 0;
+  }
+  MIX(hash, l);
+  MIX(hash, h);
+  return hash;
+}
+
+/* Mix a single-precision float.
+   Treats +0.0 and -0.0 identically.
+   Treats all NaNs identically.
+*/
+
+CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d)
+{
+  union {
+    float f;
+    uint32 i;
+  } u;
+  uint32 n;
+  /* Convert to int32 */
+  u.f = d;  n = u.i;
+  /* Normalize NaNs */
+  if ((n & 0x7F800000) == 0x7F800000 && (n & 0x007FFFFF) != 0) {
+    n = 0x7F800001;
+  }
+  /* Normalize -0 into +0 */
+  else if (n == 0x80000000) {
+    n = 0;
+  }
+  MIX(hash, n);
+  return hash;
+}
+
+/* Mix an OCaml string */
+
+CAMLexport uint32 caml_hash_mix_string(uint32 h, value s)
+{
+  mlsize_t len = caml_string_length(s);
+  mlsize_t i;
+  uint32 w;
+
+  /* Mix by 32-bit blocks (little-endian) */
+  for (i = 0; i + 4 <= len; i += 4) {
+#ifdef ARCH_BIG_ENDIAN
+    w = Byte_u(s, i)
+        | (Byte_u(s, i+1) << 8)
+        | (Byte_u(s, i+2) << 16)
+        | (Byte_u(s, i+3) << 24);
+#else
+    w = *((uint32 *) &Byte_u(s, i));
+#endif
+    MIX(h, w);
+  }
+  /* Finish with up to 3 bytes */
+  w = 0;
+  switch (len & 3) {
+  case 3: w  = Byte_u(s, i+2) << 16;   /* fallthrough */
+  case 2: w |= Byte_u(s, i+1) << 8;    /* fallthrough */
+  case 1: w |= Byte_u(s, i);
+          MIX(h, w);
+  default: /*skip*/;     /* len & 3 == 0, no extra bytes, do nothing */
+  }
+  /* Finally, mix in the length.  Ignore the upper 32 bits, generally 0. */
+  h ^= (uint32) len;
+  return h;
+}
+
+/* Maximal size of the queue used for breadth-first traversal.  */
+#define HASH_QUEUE_SIZE 256
+
+/* The generic hash function */
+
+CAMLprim value caml_hash(value count, value limit, value seed, value obj)
+{
+  value queue[HASH_QUEUE_SIZE]; /* Queue of values to examine */
+  intnat rd;                    /* Position of first value in queue */
+  intnat wr;                    /* One past position of last value in queue */
+  intnat sz;                    /* Max number of values to put in queue */
+  intnat num;                   /* Max number of meaningful values to see */
+  uint32 h;                     /* Rolling hash */
+  value v;
+  mlsize_t i, len;
+
+  sz = Long_val(limit);
+  if (sz < 0 || sz > HASH_QUEUE_SIZE) sz = HASH_QUEUE_SIZE;
+  num = Long_val(count);
+  h = Int_val(seed);
+  queue[0] = obj; rd = 0; wr = 1;
+
+  while (rd < wr && num > 0) {
+    v = queue[rd++];
+  again:
+    if (Is_long(v)) {
+      h = caml_hash_mix_intnat(h, v);
+      num--;
+    }
+    else if (Is_in_value_area(v)) {
+      switch (Tag_val(v)) {
+      case String_tag:
+        h = caml_hash_mix_string(h, v);
+        num--;
+        break;
+      case Double_tag:
+        h = caml_hash_mix_double(h, Double_val(v));
+        num--;
+        break;
+      case Double_array_tag:
+        for (i = 0, len = Wosize_val(v) / Double_wosize; i < len; i++) {
+          h = caml_hash_mix_double(h, Double_field(v, i));
+          num--;
+          if (num < 0) break;
+        }
+        break;
+      case Abstract_tag:
+        /* Block contents unknown.  Do nothing. */
+        break;
+      case Infix_tag:
+        /* Mix in the offset to distinguish different functions from
+           the same mutually-recursive definition */
+        h = caml_hash_mix_uint32(h, Infix_offset_val(v));
+        v = v - Infix_offset_val(v);
+        goto again;
+      case Forward_tag:
+        v = Forward_val(v);
+        goto again;
+      case Object_tag:
+        h = caml_hash_mix_intnat(h, Oid_val(v));
+        num--;
+        break;
+      case Custom_tag:
+        /* If no hashing function provided, do nothing. */
+        /* Only use low 32 bits of custom hash, for 32/64 compatibility */
+        if (Custom_ops_val(v)->hash != NULL) {
+          uint32 n = (uint32) Custom_ops_val(v)->hash(v);
+          h = caml_hash_mix_uint32(h, n);
+          num--;
+        }
+        break;
+      default:
+        /* Mix in the tag and size, but do not count this towards [num] */
+        h = caml_hash_mix_uint32(h, Whitehd_hd(Hd_val(v)));
+        /* Copy fields into queue, not exceeding the total size [sz] */
+        for (i = 0, len = Wosize_val(v); i < len; i++) {
+          if (wr >= sz) break;
+          queue[wr++] = Field(v, i);
+        }
+        break;
+      }
+    } else {
+      /* v is a pointer outside the heap, probably a code pointer.
+         Shall we count it?  Let's say yes by compatibility with old code. */
+      h = caml_hash_mix_intnat(h, v);
+      num--;
+    }
+  }
+  /* Final mixing of bits */
+  FINAL_MIX(h);
+  /* Fold result to the range [0, 2^30-1] so that it is a nonnegative
+     OCaml integer both on 32 and 64-bit platforms. */
+  return Val_int(h & 0x3FFFFFFFU);
+}
+
+/* The old implementation */
 
 static uintnat hash_accu;
 static intnat hash_univ_limit, hash_univ_count;

diff --git a/byterun/hash.h b/byterun/hash.h
new file mode 100644 (file)
index 0000000..22b051a
--- /dev/null
+++ b/byterun/hash.h
@@ -0,0 +1,32 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         */
+/*                                                                     */
+/*  Copyright 2011 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* Auxiliary functions for custom hash functions */
+
+#ifndef CAML_HASH_H
+#define CAML_HASH_H
+
+#include "mlvalues.h"
+
+CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d);
+CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d);
+CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d);
+CAMLextern uint32 caml_hash_mix_double(uint32 h, double d);
+CAMLextern uint32 caml_hash_mix_float(uint32 h, float d);
+CAMLextern uint32 caml_hash_mix_string(uint32 h, value s);
+
+
+#endif
+

diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c
index 3afdc9541e87a68e2b8cb022b23f222dcb4de1d9..1c329daa6973f863ed2fb3b53c8979168d68c8b4 100644 (file)
--- a/byterun/instrtrace.c
+++ b/byterun/instrtrace.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/instrtrace.h b/byterun/instrtrace.h
index c1ca4a7ec0399f359f927f49b5862371ef8a6702..686b9e4ed63151da1588b3afcea52722e1f34c40 100644 (file)
--- a/byterun/instrtrace.h
+++ b/byterun/instrtrace.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/instruct.h b/byterun/instruct.h
index c45d4ea2875ec53ed4764d2154598deda43ceeed..92f228504c327afd38e4613f85cb5bb9fd70fd08 100644 (file)
--- a/byterun/instruct.h
+++ b/byterun/instruct.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h
index ec4ed0be636f03081b5ab7874b00f1ef9cd3d0d6..ad48584d89e52dc61e3b3fa75fbe01854a292d13 100644 (file)
--- a/byterun/int64_emul.h
+++ b/byterun/int64_emul.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -27,6 +27,8 @@
 #define I64_literal(hi,lo) { lo, hi }
 #endif
 
+#define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l)
+
 /* Unsigned comparison */
 static int I64_ucompare(uint64 x, uint64 y)
 {

diff --git a/byterun/int64_format.h b/byterun/int64_format.h
index b9ae910400d6027e09d1e95f90f00537dcf6e0b6..398357a607632acd794da3b922cce4257ee9c0a8 100644 (file)
--- a/byterun/int64_format.h
+++ b/byterun/int64_format.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -52,7 +52,7 @@ static void I64_format(char * buffer, char * fmt, int64 x)
     case '1': case '2': case '3': case '4': case '5':
     case '6': case '7': case '8': case '9':
       width = atoi(p);
-      while (*p >= '0' && *p <= '9') p++;
+      while (p[1] >= '0' && p[1] <= '9') p++;
       break;
     case 'd': case 'i':
       signedconv = 1; /* fallthrough */

diff --git a/byterun/int64_native.h b/byterun/int64_native.h
index 9c079097016f0425def5d7de0711fe3bbdcd3409..9aa45e3c0f5f5df536094a6469a088513e1ce514 100644 (file)
--- a/byterun/int64_native.h
+++ b/byterun/int64_native.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -21,6 +21,7 @@
 #define CAML_INT64_NATIVE_H
 
 #define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo))
+#define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x))
 #define I64_compare(x,y) (((x) > (y)) - ((x) < (y)))
 #define I64_ult(x,y) ((uint64)(x) < (uint64)(y))
 #define I64_neg(x) (-(x))

diff --git a/byterun/intern.c b/byterun/intern.c
index f4421146225b55ca8272804f3aafd3de4be26353..8b424656e67e96a2c44bd51d132d6d64cd4429b4 100644 (file)
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -18,12 +18,15 @@
 /* The interface of this file is "intext.h" */
 
 #include <string.h>
+#include <stdio.h>
 #include "alloc.h"
+#include "callback.h"
 #include "custom.h"
 #include "fail.h"
 #include "gc.h"
 #include "intext.h"
 #include "io.h"
+#include "md5.h"
 #include "memory.h"
 #include "mlvalues.h"
 #include "misc.h"
@@ -63,6 +66,14 @@ static value intern_block;
 /* Point to the heap block allocated as destination block.
    Meaningful only if intern_extra_block is NULL. */
 
+static value * camlinternaloo_last_id = NULL;
+/* Pointer to a reference holding the last object id.
+   -1 means not available (CamlinternalOO not loaded). */
+
+static char * intern_resolve_code_pointer(unsigned char digest[16],
+                                          asize_t offset);
+static void intern_bad_code_pointer(unsigned char digest[16]) Noreturn;
+
 #define Sign_extend_shift ((sizeof(intnat) - 1) * 8)
 #define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift)
 
@@ -119,8 +130,9 @@ static void intern_rec(value *dest)
   value v, clos;
   asize_t ofs;
   header_t header;
-  char cksum[16];
+  unsigned char digest[16];
   struct custom_operations * ops;
+  char * codeptr;
 
  tailcall:
   code = read8u();
@@ -139,6 +151,22 @@ static void intern_rec(value *dest)
         dest = (value *) (intern_dest + 1);
         *intern_dest = Make_header(size, tag, intern_color);
         intern_dest += 1 + size;
+        /* For objects, we need to freshen the oid */
+        if (tag == Object_tag && camlinternaloo_last_id != (value*)-1) {
+          intern_rec(dest++);
+          intern_rec(dest++);
+          if (camlinternaloo_last_id == NULL)
+            camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id");
+          if (camlinternaloo_last_id == NULL)
+            camlinternaloo_last_id = (value*)-1;
+          else {
+            value id = Field(*camlinternaloo_last_id,0);
+            Field(dest,-1) = id;
+            Field(*camlinternaloo_last_id,0) = id + 2;
+          }
+          size -= 2;
+          if (size == 0) return;
+        }
         for(/*nothing*/; size > 1; size--, dest++)
           intern_rec(dest);
         goto tailcall;
@@ -288,12 +316,20 @@ static void intern_rec(value *dest)
         goto read_double_array;
       case CODE_CODEPOINTER:
         ofs = read32u();
-        readblock(cksum, 16);
-        if (memcmp(cksum, caml_code_checksum(), 16) != 0) {
-          intern_cleanup();
-          caml_failwith("input_value: code mismatch");
+        readblock(digest, 16);
+        codeptr = intern_resolve_code_pointer(digest, ofs);
+        if (codeptr != NULL) {
+          v = (value) codeptr;
+        } else {
+          value * function_placeholder =
+            caml_named_value ("Debugger.function_placeholder");
+          if (function_placeholder != NULL) {
+            v = *function_placeholder;
+          } else {
+            intern_cleanup();
+            intern_bad_code_pointer(digest);
+          }
         }
-        v = (value) (caml_code_area_start + ofs);
         break;
       case CODE_INFIXPOINTER:
         ofs = read32u();
@@ -328,6 +364,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
 {
   mlsize_t wosize;
 
+  if (camlinternaloo_last_id == (value*)-1)
+    camlinternaloo_last_id = NULL; /* Reset ignore flag */
   if (whsize == 0) {
     intern_obj_table = NULL;
     intern_extra_block = NULL;
@@ -551,40 +589,39 @@ CAMLprim value caml_marshal_data_size(value buff, value ofs)
   return Val_long(block_len);
 }
 
-/* Return an MD5 checksum of the code area */
-
-#ifdef NATIVE_CODE
-
-#include "md5.h"
+/* Resolution of code pointers */
 
-unsigned char * caml_code_checksum(void)
+static char * intern_resolve_code_pointer(unsigned char digest[16],
+                                          asize_t offset)
 {
-  static unsigned char checksum[16];
-  static int checksum_computed = 0;
-
-  if (! checksum_computed) {
-    struct MD5Context ctx;
-    caml_MD5Init(&ctx);
-    caml_MD5Update(&ctx,
-                   (unsigned char *) caml_code_area_start,
-                   caml_code_area_end - caml_code_area_start);
-    caml_MD5Final(checksum, &ctx);
-    checksum_computed = 1;
+  int i;
+  for (i = caml_code_fragments_table.size - 1; i >= 0; i--) {
+    struct code_fragment * cf = caml_code_fragments_table.contents[i];
+    if (! cf->digest_computed) {
+      caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start);
+      cf->digest_computed = 1;
+    }
+    if (memcmp(digest, cf->digest, 16) == 0) {
+      if (cf->code_start + offset < cf->code_end)
+        return cf->code_start + offset;
+      else
+        return NULL;
+    }
   }
-  return checksum;
+  return NULL;
 }
 
-#else
-
-#include "fix_code.h"
-
-unsigned char * caml_code_checksum(void)
+static void intern_bad_code_pointer(unsigned char digest[16])
 {
-  return caml_code_md5;
+  char msg[256];
+  sprintf(msg, "input_value: unknown code module %02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X%02X",
+          digest[0], digest[1], digest[2], digest[3],
+          digest[4], digest[5], digest[6], digest[7],
+          digest[8], digest[9], digest[10], digest[11],
+          digest[12], digest[13], digest[14], digest[15]);
+  caml_failwith(msg);
 }
 
-#endif
-
 /* Functions for writing user-defined marshallers */
 
 CAMLexport int caml_deserialize_uint_1(void)

diff --git a/byterun/interp.c b/byterun/interp.c
index 7bcdf7acb35298bc1f51a851764940077eeb28fd..cbec02a5cbca3d8a136e5e050b11c27358355f4b 100644 (file)
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/interp.h b/byterun/interp.h
index 9eb73394057052c9e30f89f1fb1b7e2c9eb27d4e..7c3d26f28949994ec0a254c173dd864b1aa4586c 100644 (file)
--- a/byterun/interp.h
+++ b/byterun/interp.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/intext.h b/byterun/intext.h
index b757d171869a77c8995bcf819fb07f9428693bdf..b287e5cdb4739a7530d2eefdc1974ac7d40ac838 100644 (file)
--- a/byterun/intext.h
+++ b/byterun/intext.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -81,6 +81,10 @@ void caml_output_val (struct channel * chan, value v, value flags);
 
 /* </private> */
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 CAMLextern void caml_output_value_to_malloc(value v, value flags,
                                             /*out*/ char ** buf,
                                             /*out*/ intnat * len);
@@ -100,7 +104,7 @@ value caml_input_val (struct channel * chan);
 /* </private> */
 
 CAMLextern value caml_input_val_from_string (value str, intnat ofs);
-  /* Read a structured value from the Caml string [str], starting
+  /* Read a structured value from the OCaml string [str], starting
      at offset [ofs]. */
 CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs);
   /* Read a structured value from a malloced buffer.  [data] points
@@ -147,16 +151,20 @@ CAMLextern void caml_deserialize_error(char * msg);
 /* <private> */
 
 /* Auxiliary stuff for sending code pointers */
-unsigned char * caml_code_checksum (void);
 
-#ifndef NATIVE_CODE
-#include "fix_code.h"
-#define caml_code_area_start ((char *) caml_start_code)
-#define caml_code_area_end ((char *) caml_start_code + caml_code_size)
-#else
-extern char * caml_code_area_start, * caml_code_area_end;
-#endif
+struct code_fragment {
+  char * code_start;
+  char * code_end;
+  unsigned char digest[16];
+  char digest_computed;
+};
+
+struct ext_table caml_code_fragments_table;
 
 /* </private> */
 
+#ifdef __cplusplus
+}
+#endif
+
 #endif /* CAML_INTEXT_H */

diff --git a/byterun/ints.c b/byterun/ints.c
index 51a9a3b3b08656c235c8e1668baf5c5350ee4454..34b5db238ae8eeebcce156febb3deb5753e4450f 100644 (file)
--- a/byterun/ints.c
+++ b/byterun/ints.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -142,7 +142,7 @@ static char * parse_format(value fmt,
   char lastletter;
   mlsize_t len, len_suffix;
 
-  /* Copy Caml format fmt to format_string,
+  /* Copy OCaml format fmt to format_string,
      adding the suffix before the last letter of the format */
   len = caml_string_length(fmt);
   len_suffix = strlen(suffix);
@@ -227,7 +227,8 @@ CAMLexport struct custom_operations caml_int32_ops = {
   int32_cmp,
   int32_hash,
   int32_serialize,
-  int32_deserialize
+  int32_deserialize,
+  custom_compare_ext_default
 };
 
 CAMLexport value caml_copy_int32(int32 i)
@@ -381,7 +382,11 @@ static int int64_cmp(value v1, value v2)
 
 static intnat int64_hash(value v)
 {
-  return I64_to_intnat(Int64_val(v));
+  int64 x = Int64_val(v);
+  uint32 lo, hi;
+
+  I64_split(x, hi, lo);
+  return hi ^ lo;
 }
 
 static void int64_serialize(value v, uintnat * wsize_32,
@@ -410,7 +415,8 @@ CAMLexport struct custom_operations caml_int64_ops = {
   int64_cmp,
   int64_hash,
   int64_serialize,
-  int64_deserialize
+  int64_deserialize,
+  custom_compare_ext_default
 };
 
 CAMLexport value caml_copy_int64(int64 i)
@@ -606,7 +612,14 @@ static int nativeint_cmp(value v1, value v2)
 
 static intnat nativeint_hash(value v)
 {
-  return Nativeint_val(v);
+  intnat n = Nativeint_val(v);
+#ifdef ARCH_SIXTYFOUR
+  /* 32/64 bits compatibility trick.  See explanations in file "hash.c",
+     function caml_hash_mix_intnat. */
+  return (n >> 32) ^ (n >> 63) ^ n;
+#else
+  return n;
+#endif
 }
 
 static void nativeint_serialize(value v, uintnat * wsize_32,
@@ -654,7 +667,8 @@ CAMLexport struct custom_operations caml_nativeint_ops = {
   nativeint_cmp,
   nativeint_hash,
   nativeint_serialize,
-  nativeint_deserialize
+  nativeint_deserialize,
+  custom_compare_ext_default
 };
 
 CAMLexport value caml_copy_nativeint(intnat i)

diff --git a/byterun/io.c b/byterun/io.c
index e7c7f048529308aca36c105d5debd40dee0a6efd..600887a889ec7d271f631bdd7840f61619766102 100644 (file)
--- a/byterun/io.c
+++ b/byterun/io.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -117,7 +117,7 @@ CAMLexport file_offset caml_channel_size(struct channel *channel)
   file_offset end;
   int fd;
 
-  /* We extract data from [channel] before dropping the Caml lock, in case
+  /* We extract data from [channel] before dropping the OCaml lock, in case
      someone else touches the block. */
   fd = channel->fd;
   offset = channel->offset;
@@ -411,7 +411,7 @@ CAMLexport intnat caml_input_scan_line(struct channel *channel)
   return (p - channel->curr);
 }
 
-/* Caml entry points for the I/O functions.  Wrap struct channel *
+/* OCaml entry points for the I/O functions.  Wrap struct channel *
    objects into a heap-allocated object.  Perform locking
    and unlocking around the I/O operations. */
 /* FIXME CAMLexport, but not in io.h  exported for Cash ? */
@@ -431,13 +431,19 @@ static int compare_channel(value vchan1, value vchan2)
   return (chan1 == chan2) ? 0 : (chan1 < chan2) ? -1 : 1;
 }
 
+static intnat hash_channel(value vchan)
+{
+  return (intnat) (Channel(vchan));
+}
+
 static struct custom_operations channel_operations = {
   "_chan",
   caml_finalize_channel,
   compare_channel,
-  custom_hash_default,
+  hash_channel,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 CAMLexport value caml_alloc_channel(struct channel *chan)

diff --git a/byterun/io.h b/byterun/io.h
index d02a5a72fcc04aab9d48d0296038cc306aba12b8..89a85380c7d6bb051879053343d6b293501cc35b 100644 (file)
--- a/byterun/io.h
+++ b/byterun/io.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -22,7 +22,7 @@
 #include "mlvalues.h"
 
 #ifndef IO_BUFFER_SIZE
-#define IO_BUFFER_SIZE 4096
+#define IO_BUFFER_SIZE 65536
 #endif
 
 #if defined(_WIN32)

diff --git a/byterun/lexing.c b/byterun/lexing.c
index 6e74795c2303c766647d5c234ec03e7c75353322..cb763bce93b6352995bc49b06d25f1087c577d0a 100644 (file)
--- a/byterun/lexing.c
+++ b/byterun/lexing.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/main.c b/byterun/main.c
index e6afb1b3265b6d344bbaf14ee8963ce9194cd0e0..63355840f65b57de202de1d73f7ec6c601deb071 100644 (file)
--- a/byterun/main.c
+++ b/byterun/main.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index b9ec8cbfe03caf9b85ea25f13d8c9cb307f5fcad..aeb192fdeace617543184be1e7784e77317531ce 100644 (file)
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/major_gc.h b/byterun/major_gc.h
index 12f8806705e7ce03a662906d0ce613ad3b7c864d..427312784c7d01a77b5e1447f6aaaeb45b9a9a20 100644 (file)
--- a/byterun/major_gc.h
+++ b/byterun/major_gc.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/md5.c b/byterun/md5.c
index d0b6e5e46291c3fdd673e8a10021923db2448893..a2125127326b3a25b317ef69a0fcdcb9f33d9a1d 100644 (file)
--- a/byterun/md5.c
+++ b/byterun/md5.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -68,6 +68,15 @@ CAMLprim value caml_md5_chan(value vchan, value len)
   CAMLreturn (res);
 }
 
+CAMLexport void caml_md5_block(unsigned char digest[16], 
+                               void * data, uintnat len)
+{
+  struct MD5Context ctx;
+  caml_MD5Init(&ctx);
+  caml_MD5Update(&ctx, data, len);
+  caml_MD5Final(digest, &ctx);
+}
+
 /*
  * This code implements the MD5 message-digest algorithm.
  * The algorithm is due to Ron Rivest.  This code was

diff --git a/byterun/md5.h b/byterun/md5.h
index b92b02ad1215ade194534e8416a6c041ceba2f23..0c4239e550b80e40a6c24e82f8b74965726777c0 100644 (file)
--- a/byterun/md5.h
+++ b/byterun/md5.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -24,6 +24,8 @@
 
 CAMLextern value caml_md5_string (value str, value ofs, value len);
 CAMLextern value caml_md5_chan (value vchan, value len);
+CAMLextern void caml_md5_block(unsigned char digest[16], 
+                               void * data, uintnat len);
 
 struct MD5Context {
         uint32 buf[4];

diff --git a/byterun/memory.c b/byterun/memory.c
index bc4c88df15b5310c391633d60cb93937ddc1c9e0..b99825d185264cb7e4648f037251bd55b9867507 100644 (file)
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */
@@ -255,6 +255,8 @@ void caml_free_for_heap (char *mem)
    caller.  All other blocks must have the color [caml_allocation_color(m)].
    The caller must update [caml_allocated_words] if applicable.
    Return value: 0 if no error; -1 in case of error.
+
+   See also: caml_compact_heap, which duplicates most of this function.
 */
 int caml_add_to_heap (char *m)
 {
@@ -353,7 +355,7 @@ void caml_shrink_heap (char *chunk)
 {
   char **cp;
 
-  /* Never deallocate the first block, because caml_heap_start is both the
+  /* Never deallocate the first chunk, because caml_heap_start is both the
      first block and the base address for page numbers, and we don't
      want to shift the page table, it's too messy (see above).
      It will never happen anyway, because of the way compaction works.

diff --git a/byterun/memory.h b/byterun/memory.h
index f8fb8ca2bab9d97f79b91b63b2ea5f3202446d0a..69f5ff91c80f5830e94c36833f6fb0e62dfaeab1 100644 (file)
--- a/byterun/memory.h
+++ b/byterun/memory.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */
@@ -30,6 +30,11 @@
 #include "misc.h"
 #include "mlvalues.h"
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
 CAMLextern value caml_alloc_shr (mlsize_t, tag_t);
 CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t);
 CAMLextern void caml_alloc_dependent_memory (mlsize_t);
@@ -102,7 +107,7 @@ int caml_page_table_initialize(mlsize_t bytesize);
                                           CAMLassert ((tag_t) (tag) < 256); \
                                  CAMLassert ((wosize) <= Max_young_wosize); \
   caml_young_ptr -= Bhsize_wosize (wosize);                                 \
-  if (caml_young_ptr < caml_young_limit){                                   \
+  if (caml_young_ptr < caml_young_start){                                   \
     caml_young_ptr += Bhsize_wosize (wosize);                               \
     Setup_for_gc;                                                           \
     caml_minor_collection ();                                               \
@@ -168,15 +173,15 @@ CAMLextern struct caml__roots_block *caml_local_roots;  /* defined in roots.c */
 
    If you need local variables of type [value], declare them with one
    or more calls to the [CAMLlocal] macros at the beginning of the
-   function. Use [CAMLlocalN] (at the beginning of the function) to
-   declare an array of [value]s.
+   function, after the call to CAMLparam.  Use [CAMLlocalN] (at the
+   beginning of the function) to declare an array of [value]s.
 
    Your function may raise an exception or return a [value] with the
    [CAMLreturn] macro.  Its argument is simply the [value] returned by
    your function.  Do NOT directly return a [value] with the [return]
    keyword.  If your function returns void, use [CAMLreturn0].
 
-   All the identifiers beginning with "caml__" are reserved by Caml.
+   All the identifiers beginning with "caml__" are reserved by OCaml.
    Do not use them for anything (local or global variables, struct or
    union tags, macros, etc.)
 */
@@ -341,7 +346,7 @@ CAMLextern struct caml__roots_block *caml_local_roots;  /* defined in roots.c */
    It must contain all values in C local variables and function parameters
    at the time the minor GC is called.
    Usage:
-   After initialising your local variables to legal Caml values, but before
+   After initialising your local variables to legal OCaml values, but before
    calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where
    v1 ... vn are your variables of type [value] that you want to be updated
    across allocations.
@@ -435,7 +440,7 @@ CAMLextern void caml_remove_global_root (value *);
    the value of this variable, it must do so by calling
    [caml_modify_generational_global_root].  The [value *] pointer
    passed to [caml_register_generational_global_root] must contain
-   a valid Caml value before the call.
+   a valid OCaml value before the call.
    In return for these constraints, scanning of memory roots during
    minor collection is made more efficient. */
 
@@ -456,4 +461,8 @@ CAMLextern void caml_remove_generational_global_root (value *);
 
 CAMLextern void caml_modify_generational_global_root(value *r, value newval);
 
+#ifdef __cplusplus
+}
+#endif
+
 #endif /* CAML_MEMORY_H */

diff --git a/byterun/meta.c b/byterun/meta.c
index 1ed4fbddd56505063e10ebc866ca3c3b5c371d69..a547b991b549768be53210a5cc296530dfc0eef0 100644 (file)
--- a/byterun/meta.c
+++ b/byterun/meta.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -15,6 +15,7 @@
 
 /* Primitives for the toplevel */
 
+#include <string.h>
 #include "alloc.h"
 #include "config.h"
 #include "fail.h"
@@ -61,6 +62,17 @@ CAMLprim value caml_reify_bytecode(value prog, value len)
   return clos;
 }
 
+CAMLprim value caml_register_code_fragment(value prog, value len, value digest)
+{
+  struct code_fragment * cf = caml_stat_alloc(sizeof(struct code_fragment));
+  cf->code_start = (char *) prog;
+  cf->code_end = (char *) prog + Long_val(len);
+  memcpy(cf->digest, String_val(digest), 16);
+  cf->digest_computed = 1;
+  caml_ext_table_add(&caml_code_fragments_table, cf);
+  return Val_unit;
+}
+
 CAMLprim value caml_realloc_global(value size)
 {
   mlsize_t requested_size, actual_size, i;

diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index 91aa29799bc671d551648cd24f5879e3a01df653..8b8b8ff0ed60c50d3be7bb3a87b6c476158281f1 100644 (file)
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */
@@ -160,9 +160,14 @@ void caml_oldify_one (value v, value *p)
 
         Assert (tag == Forward_tag);
         if (Is_block (f)){
-          vv = Is_in_value_area(f);
-          if (vv) {
+          if (Is_young (f)){
+            vv = 1;
             ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f);
+          }else{
+            vv = Is_in_value_area(f);
+            if (vv){
+              ft = Tag_val (f);
+            }
           }
         }
         if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){

diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h
index 8e834129bf526fcf24df61cefeeea8f656fe4154..82c82cd3f621e606df6f5f6a560077130391f5e2 100644 (file)
--- a/byterun/minor_gc.h
+++ b/byterun/minor_gc.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/misc.c b/byterun/misc.c
index e8597ee38cb1bcff0911625916887fba992bfde9..927cbd81b1d009e393666e8ec00094747126a224 100644 (file)
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/misc.h b/byterun/misc.h
index d0aaffd1a20d9b71c8e88036a4e2761075f96aee..e970d3d032e20ee0bd8fa43e55531666de3d84f1 100644 (file)
--- a/byterun/misc.h
+++ b/byterun/misc.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
index d76c1f1df8b69f11065ca73b9c1c548a4f89b4ca..d560d1b3aef0b5008cc55e30df7b51ecbd368f0b 100644 (file)
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -22,6 +22,10 @@
 #include "config.h"
 #include "misc.h"
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 /* Definitions
 
   word: Four bytes on 32 and 16 bit architectures,
@@ -245,6 +249,9 @@ CAMLextern void caml_Store_double_val (value,double);
   double caml__temp_d = (d); \
   Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \
 }while(0)
+CAMLextern mlsize_t caml_array_length (value);   /* size in items */
+CAMLextern int caml_is_double_array (value);   /* 0 is false, 1 is true */
+
 
 /* Custom blocks.  They contain a pointer to a "method suite"
    of functions (for finalization, comparison, hashing, etc)
@@ -291,5 +298,9 @@ CAMLextern header_t caml_atom_table[];
 
 extern value caml_global_data;
 
+#ifdef __cplusplus
+}
+#endif
+
 
 #endif /* CAML_MLVALUES_H */

diff --git a/byterun/obj.c b/byterun/obj.c
index e085d672772ad3fe4eb24b2413ea16d32a3ddf88..7d09105b78c09773aa75f868d6e0e70f12d5f7c7 100644 (file)
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -171,7 +171,7 @@ CAMLprim value caml_obj_add_offset (value v, value offset)
 }
 
 /* The following functions are used in stdlib/lazy.ml.
-   They are not written in O'Caml because they must be atomic with respect
+   They are not written in OCaml because they must be atomic with respect
    to the GC.
  */
 
@@ -191,7 +191,7 @@ CAMLprim value caml_lazy_make_forward (value v)
   CAMLlocal1 (res);
 
   res = caml_alloc_small (1, Forward_tag);
-  Modify (&Field (res, 0), v);
+  Field (res, 0) = v;
   CAMLreturn (res);
 }
 

diff --git a/byterun/osdeps.h b/byterun/osdeps.h
index 248b3f6aa344ddb5960e12f3e7db86bac7500ab0..902ea2de654e8e750b9db8c3e09c89aa39ac12d9 100644 (file)
--- a/byterun/osdeps.h
+++ b/byterun/osdeps.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
 /*                                                                     */

diff --git a/byterun/parsing.c b/byterun/parsing.c
index bcb9e5faa52388690a75f85a30761fe5cc01518e..3d5ea83323a9fd397e2ce23c84518a60b43e947c 100644 (file)
--- a/byterun/parsing.c
+++ b/byterun/parsing.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -125,7 +125,7 @@ static void print_token(struct parser_tables *tables, int state, value tok)
             state, token_name(tables->names_block, Tag_val(tok)));
     v = Field(tok, 0);
     if (Is_long(v))
-      fprintf(stderr, "%ld", Long_val(v));
+      fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
     else if (Tag_val(v) == String_tag)
       fprintf(stderr, "%s", String_val(v));
     else if (Tag_val(v) == Double_tag)

diff --git a/byterun/prims.h b/byterun/prims.h
index d8c1671e1bba9171d950614752397ad4b7505af9..3d7bb6d82a7ff1540910c538663fc4697b2ad27b 100644 (file)
--- a/byterun/prims.h
+++ b/byterun/prims.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/printexc.c b/byterun/printexc.c
index f72157ff08d6c7a1bcde56c1f7cb6eac07aef490..e891d9c67714c937786d67b3366a87ef37ab04b5 100644 (file)
--- a/byterun/printexc.c
+++ b/byterun/printexc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -60,7 +60,8 @@ CAMLexport char * caml_format_exception(value exn)
     /* Check for exceptions in the style of Match_failure and Assert_failure */
     if (Wosize_val(exn) == 2 &&
         Is_block(Field(exn, 1)) &&
-        Tag_val(Field(exn, 1)) == 0) {
+        Tag_val(Field(exn, 1)) == 0 &&
+        caml_is_special_exception(Field(exn, 0))) {
       bucket = Field(exn, 1);
       start = 0;
     } else {
@@ -72,7 +73,7 @@ CAMLexport char * caml_format_exception(value exn)
       if (i > start) add_string(&buf, ", ");
       v = Field(bucket, i);
       if (Is_long(v)) {
-        sprintf(intbuf, "%ld", Long_val(v));
+        sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
         add_string(&buf, intbuf);
       } else if (Tag_val(v) == String_tag) {
         add_char(&buf, '"');

diff --git a/byterun/printexc.h b/byterun/printexc.h
index e7d17688829209d48e79e8a852240cfe38ba5ddd..4624086cb33516d5c4753ab4960b4aacc1d0c2fe 100644 (file)
--- a/byterun/printexc.h
+++ b/byterun/printexc.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -20,8 +20,16 @@
 #include "misc.h"
 #include "mlvalues.h"
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
 CAMLextern char * caml_format_exception (value);
 void caml_fatal_uncaught_exception (value) Noreturn;
 
+#ifdef __cplusplus
+}
+#endif
 
 #endif /* CAML_PRINTEXC_H */

diff --git a/byterun/reverse.h b/byterun/reverse.h
index e80d1f7d9f31ac673b49c3a229ca54ba1518a4cf..a48b6f255882272b6940ad165c30883bf93f5cc2 100644 (file)
--- a/byterun/reverse.h
+++ b/byterun/reverse.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/roots.c b/byterun/roots.c
index 74fbb41edb92d9fc79e7be03ef8197974553bf68..8a4d23b33d982c00776ef47caac9ca37ab6e710f 100644 (file)
--- a/byterun/roots.c
+++ b/byterun/roots.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/roots.h b/byterun/roots.h
index 95c2f63f7abbf9eb36ec4fc6b8786d53209f2545..f2d3bd69400dd83ba6ae837599366007cb767376 100644 (file)
--- a/byterun/roots.h
+++ b/byterun/roots.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/signals.c b/byterun/signals.c
index 90fe8919621334b63ac651b189ac4ffed26dd3be..40ba0ab5e7202fccc9c8f1b9e441d5e6dcf74e63 100644 (file)
--- a/byterun/signals.c
+++ b/byterun/signals.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/signals.h b/byterun/signals.h
index e5ba9877734de2e87d22033409350d0725389e9c..fb03b30dd55ad32c30d1eeb4292fe7227d5dcbf0 100644 (file)
--- a/byterun/signals.h
+++ b/byterun/signals.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -22,6 +22,10 @@
 #include "misc.h"
 #include "mlvalues.h"
 
+#ifdef __cplusplus
+extern "C" {
+#endif
+
 /* <private> */
 CAMLextern intnat volatile caml_signals_are_pending;
 CAMLextern intnat volatile caml_pending_signals[];
@@ -48,4 +52,8 @@ CAMLextern int (*caml_try_leave_blocking_section_hook)(void);
 CAMLextern void (* volatile caml_async_action_hook)(void);
 /* </private> */
 
+#ifdef __cplusplus
+}
+#endif
+
 #endif /* CAML_SIGNALS_H */

diff --git a/byterun/signals_byt.c b/byterun/signals_byt.c
index 523814938f596474276467ac8cab774a0a19def2..f52ee5a455e2eed9f2ef3d1b1afd0cff38d46868 100644 (file)
--- a/byterun/signals_byt.c
+++ b/byterun/signals_byt.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/signals_machdep.h b/byterun/signals_machdep.h
index 08c5f4cb829d7734962ffd4e60bbfc3156729360..0308d3c1f0adb804d229f0b6d681448700fa8819 100644 (file)
--- a/byterun/signals_machdep.h
+++ b/byterun/signals_machdep.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/stacks.c b/byterun/stacks.c
index ed06f953465083f18b8e58ea5629a14255821b61..5f7a871d04c20dd02f032ba266b8375d9389046d 100644 (file)
--- a/byterun/stacks.c
+++ b/byterun/stacks.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/stacks.h b/byterun/stacks.h
index 48e8acc9c55bd61a6f6ef5341181c76534df7abb..f8469572d82fa8dd6f3e079ff2e307fd642c233a 100644 (file)
--- a/byterun/stacks.h
+++ b/byterun/stacks.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/startup.c b/byterun/startup.c
index 20e61e7d2f732b9c3c5a8a36f09a54b37d49ea84..feb5029ae960228c4664afa3c48567becd9dbd33 100644 (file)
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -216,7 +216,7 @@ static char * read_section(int fd, struct exec_trailer *trail, char *name)
 Algorithm:
   1-  If argument 0 is a valid byte-code file that does not start with #!,
       then we are in case 3 and we pass the same command line to the
-      Objective Caml program.
+      OCaml program.
   2-  In all other cases, we parse the command line as:
         (whatever) [options] bytecode args...
       and we strip "(whatever) [options]" from the command line.
@@ -247,7 +247,7 @@ static int parse_command_line(char **argv)
 #endif
     case 'v':
       if (!strcmp (argv[i], "-version")){
-        printf ("The Objective Caml runtime, version " OCAML_VERSION "\n");
+        printf ("The OCaml runtime, version " OCAML_VERSION "\n");
         exit (0);
       }else if (!strcmp (argv[i], "-vnum")){
         printf (OCAML_VERSION "\n");
@@ -370,12 +370,12 @@ CAMLexport void caml_main(char **argv)
     fd = caml_attempt_open(&exe_name, &trail, 1);
     switch(fd) {
     case FILE_NOT_FOUND:
-      caml_fatal_error_arg("Fatal error: cannot find file %s\n", argv[pos]);
+      caml_fatal_error_arg("Fatal error: cannot find file '%s'\n", argv[pos]);
       break;
     case BAD_BYTECODE:
       caml_fatal_error_arg(
-        "Fatal error: the file %s is not a bytecode executable file\n",
-        argv[pos]);
+        "Fatal error: the file '%s' is not a bytecode executable file\n",
+        exe_name);
       break;
     }
   }

diff --git a/byterun/startup.h b/byterun/startup.h
index 0d1a5a60469328d85a1f796f292af93d5dd1ebf8..5a42a73aaf49ea815cde9d2be2d24921bc7b605a 100644 (file)
--- a/byterun/startup.h
+++ b/byterun/startup.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/str.c b/byterun/str.c
index 760b154e30603e5476691f97ffcc02bdbf519fae..3941cae17dd2e3e6223fafef8b33bbfd8a3a90fc 100644 (file)
--- a/byterun/str.c
+++ b/byterun/str.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/sys.c b/byterun/sys.c
index 9928910f739a9658317720b78ca967b42a053787..ce364d8c1a35d22a001c861fec8b4c5e4ddb58a0 100644 (file)
--- a/byterun/sys.c
+++ b/byterun/sys.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -51,10 +51,6 @@
 #include "stacks.h"
 #include "sys.h"
 
-#ifndef _WIN32
-extern int errno;
-#endif
-
 static char * error_message(void)
 {
   return strerror(errno);
@@ -295,27 +291,49 @@ CAMLprim value caml_sys_time(value unit)
 }
 
 #ifdef _WIN32
-extern intnat caml_win32_random_seed (void);
+extern int caml_win32_random_seed (intnat data[16]);
 #endif
 
 CAMLprim value caml_sys_random_seed (value unit)
 {
+  intnat data[16];
+  int n, i;
+  value res;
 #ifdef _WIN32
-  return Val_long(caml_win32_random_seed());
+  n = caml_win32_random_seed(data);
 #else
-  intnat seed;
+  int fd;
+  n = 0;
+  /* Try /dev/urandom first */
+  fd = open("/dev/urandom", O_RDONLY, 0);
+  if (fd != -1) {
+    unsigned char buffer[12];
+    int nread = read(fd, buffer, 12);
+    close(fd);
+    while (nread > 0) data[n++] = buffer[--nread];
+  }
+  /* If the read from /dev/urandom fully succeeded, we now have 96 bits
+     of good random data and can stop here.  Otherwise, complement
+     whatever we got (probably nothing) with some not-very-random data. */
+  if (n < 12) {
 #ifdef HAS_GETTIMEOFDAY
-  struct timeval tv;
-  gettimeofday(&tv, NULL);
-  seed = tv.tv_sec ^ tv.tv_usec;
+    struct timeval tv;
+    gettimeofday(&tv, NULL);
+    data[n++] = tv.tv_usec;
+    data[n++] = tv.tv_sec;
 #else
-  seed = time (NULL);
+    data[n++] = time(NULL);
 #endif
 #ifdef HAS_UNISTD
-  seed ^= (getppid() << 16) ^ getpid();
+    data[n++] = getpid();
+    data[n++] = getppid();
 #endif
-  return Val_long(seed);
+  }
 #endif
+  /* Convert to an OCaml array of ints */
+  res = caml_alloc_small(n, 0);
+  for (i = 0; i < n; i++) Field(res, i) = Val_long(data[i]);
+  return res;
 }
 
 CAMLprim value caml_sys_get_config(value unit)
@@ -324,9 +342,14 @@ CAMLprim value caml_sys_get_config(value unit)
   CAMLlocal2 (result, ostype);
 
   ostype = caml_copy_string(OCAML_OS_TYPE);
-  result = caml_alloc_small (2, 0);
+  result = caml_alloc_small (3, 0);
   Field(result, 0) = ostype;
   Field(result, 1) = Val_long (8 * sizeof(value));
+#ifdef ARCH_BIG_ENDIAN
+  Field(result, 2) = Val_true;
+#else
+  Field(result, 2) = Val_false;
+#endif
   CAMLreturn (result);
 }
 

diff --git a/byterun/sys.h b/byterun/sys.h
index 4ad8011d9c8dab10b48970ff3f7819bb4ce8f49c..c6f5d3204b3e8ff99c340c25442ca5c2268afd0d 100644 (file)
--- a/byterun/sys.h
+++ b/byterun/sys.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/terminfo.c b/byterun/terminfo.c
index e4502fb025e25dd6c176e8f61c0289d51666f961..67975696799f62e8a5091d07f14ec763c193f68b 100644 (file)
--- a/byterun/terminfo.c
+++ b/byterun/terminfo.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/ui.h b/byterun/ui.h
index fcd9cd9f88a7ce0b80bd452074e0316de05ff79b..0c3309b3937112094455af43f61058f2c2ba895c 100644 (file)
--- a/byterun/ui.h
+++ b/byterun/ui.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Damien Doligez, projet Para, INRIA Rocquencourt          */
 /*                                                                     */

diff --git a/byterun/unix.c b/byterun/unix.c
index cdc1f2a018c8acc1a4320418915251060bd899ae..664c32b18c288319ed0048a57f1ed52834a93c0a 100644 (file)
--- a/byterun/unix.c
+++ b/byterun/unix.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
 /*                                                                     */

diff --git a/byterun/weak.c b/byterun/weak.c
index c6c4a223fe440b8d9ff4012f9ff93bfcfbfebb92..efdb15e9c4091344dd19ae912ae16fec730968a3 100644 (file)
--- a/byterun/weak.c
+++ b/byterun/weak.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/byterun/weak.h b/byterun/weak.h
index 270082dbf2d7dd08029ecdbea225cee23bc2cc3f..a30001a7e873e040f86c8de2dcc5373072bea05a 100644 (file)
--- a/byterun/weak.h
+++ b/byterun/weak.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Damien Doligez, projet Para, INRIA Rocquencourt          */
 /*                                                                     */

diff --git a/byterun/win32.c b/byterun/win32.c
index 866977b121042233a3760d070b7196c30f316387..4cc38415291bd915c64fee3caf201e95df969c97 100644 (file)
--- a/byterun/win32.c
+++ b/byterun/win32.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
 /*                                                                     */
@@ -528,18 +528,15 @@ void caml_win32_overflow_detection()
 
 /* Seeding of pseudo-random number generators */
 
-intnat caml_win32_random_seed (void)
+int caml_win32_random_seed (intnat data[16])
 {
-  intnat seed;
-  SYSTEMTIME t;
-
-  GetLocalTime(&t);
-  seed = t.wMonth;
-  seed = (seed << 5) ^ t.wDay;
-  seed = (seed << 4) ^ t.wHour;
-  seed = (seed << 5) ^ t.wMinute;
-  seed = (seed << 5) ^ t.wSecond;
-  seed = (seed << 9) ^ t.wMilliseconds;
-  seed ^= GetCurrentProcessId();
-  return seed;
+  /* For better randomness, consider:
+     http://msdn.microsoft.com/library/en-us/seccrypto/security/rtlgenrandom.asp
+  */
+  FILETIME t;
+  GetSystemTimeAsFileTime(&t);
+  data[0] = t.dwLowDateTime;
+  data[1] = t.dwHighDateTime;
+  data[2] = GetCurrentProcessId();
+  return 3;
 }

diff --git a/camlp4/.cvsignore b/camlp4/.cvsignore
deleted file mode 100644 (file)
index 493096e..0000000
--- a/camlp4/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.cm*
-.cache-status
-*.tmp.ml

diff --git a/camlp4/.ignore b/camlp4/.ignore
new file mode 100644 (file)
index 0000000..481c691
--- /dev/null
+++ b/camlp4/.ignore
@@ -0,0 +1,2 @@
+.cache-status
+*.tmp.ml

diff --git a/camlp4/CHANGES b/camlp4/CHANGES
index ef48fc42511aa509133af586e76829e94c032e61..0251cd1638aa4b0ac130d5ef11052bb8a90b07d6 100644 (file)
--- a/camlp4/CHANGES
+++ b/camlp4/CHANGES
@@ -497,7 +497,7 @@ Camlp4 Version 3.00:
 - [Apr 17, 00] Added support for labels and variants.
 - [Mar 28, 00] Improved the grammars: now the rules starting with n
   terminals are locally LL(n), i.e. if any of the terminal fails, it is
-  not Error but just Failure. Allows to write the Ocaml syntax case:
+  not Error but just Failure. Allows to write the OCaml syntax case:
         ( operator )
         ( expr )
   with the problem of "( - )" as:
@@ -518,7 +518,7 @@ Camlp4 Version 2.04:
 
 - [Nov 23, 99] Changed the module name Config into Oconfig, because of
   conflict problem when applications want to link with the module Config of
-  Ocaml.
+  OCaml.
 
 Camlp4 Version 2.03:
 --------------------
@@ -534,9 +534,9 @@ Camlp4 Version 2.03:
   - [Mar 9, 99] Added missing case in pr_depend.ml.
 
 * Other:
-  - [Sep 10, 99] Updated from current Ocaml new interfaces.
+  - [Sep 10, 99] Updated from current OCaml new interfaces.
   - [Jul 9, 99] Added stream type constraint in pa_oop.ml to reflect the same
-    change in Ocaml.
+    change in OCaml.
   - [Jun 24, 99] Added missing "constraint" construction in types
   - [Jun 15, 99] Added option -I for command "mkcamlp4".
   - [May 14, 99] Added man pages (links) for camlp4o, camlp4r, mkcamlp4, ocpp
@@ -555,11 +555,11 @@ Camlp4 Version 2.02:
 --------------------
 
 * Parsing:
-  - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect Ocaml parsing of the
+  - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect OCaml parsing of the
     program example: "type t = F(B).t"
   - [Jan 30, 99] Fixed bug "pa_op.ml", could not parse "parser | [<>] -> ()".
   - [Jan 16, 99] Added "define" and "undef" in "pa_ifdef.cmo".
-  - [Dec 22, 98] Fixed precedence of "!=" in Ocaml syntax
+  - [Dec 22, 98] Fixed precedence of "!=" in OCaml syntax
 
 * Printing:
   - [Mar 4, 99] Added pr_depend.cmo for printing file dependencies.
@@ -603,7 +603,7 @@ Grammar interface
 Missing features added
 * Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo)
 * Added print "assert" statement (pr_o.cmo, pr_r.cmo)
-* Added parsing of infix operators like in Ocaml (e.g. |||) in pa_o.cmo
+* Added parsing of infix operators like in OCaml (e.g. |||) in pa_o.cmo
 
 Compilation
 * Added "make scratch"
@@ -636,20 +636,20 @@ Camlp4 Version 2.00:
 --------------------
 
 * Designation "righteous" has been renamed "revised".
-* Added class and objects in Ocaml printing (pr_o.cmo), revised parsing
+* Added class and objects in OCaml printing (pr_o.cmo), revised parsing
   (pa_r.cmo) and printing (pr_r.cmo).
-* Fixed bug in Ocaml syntax: let _, x = 1, 2;; was refused.
+* Fixed bug in OCaml syntax: let _, x = 1, 2;; was refused.
 
 Camlp4 Version 2.00--1:
 -----------------------
 
-* Added classes and objects in Ocaml syntax (pa_o.cmo)
+* Added classes and objects in OCaml syntax (pa_o.cmo)
 * Fixed pr_r.cmo et pr_r.cmo which wrote on stdout, even when option -o
 
 Camlp4 Version 2.00--:
 ----------------------
 
-* Adapted for Ocaml 2.00.
+* Adapted for OCaml 2.00.
 * No objects and classes in this version.
 
 * Added "let module" parsing and printing.
@@ -672,7 +672,7 @@ Camlp4 Version 2.00--:
 * Added missing statement "include" in signature item in normal and righteous
   syntaxes
 * Changed precedence of ":=" and "<-" in normal syntax (pa_o et pr_o):
-  now before "or", like in Ocaml compiler.
+  now before "or", like in OCaml compiler.
 * Same change in righteous syntax, by symmetry.
 
 Camlp4 Version 1.07.2:
@@ -684,8 +684,8 @@ Errors and missings in normal and righteous syntaxes.
 * Added missing syntax (normal): type foo = bar = {......}
 * Added missing syntax (normal): did not accept separators before ending
   constructions (many of them).
-* Fixed bug: "assert false" is now of type 'a, like in Ocaml.
-* Fixed to match Ocaml feature: "\^" is "\^" in Ocaml, but just "^" in Camlp4.
+* Fixed bug: "assert false" is now of type 'a, like in OCaml.
+* Fixed to match OCaml feature: "\^" is "\^" in OCaml, but just "^" in Camlp4.
 * Fixed bug in Windows NT/95: problem in backslash before newlines in strings
 
 Grammars, EXTEND, DELETE_RULE
@@ -736,7 +736,7 @@ Camlp4 Version 1.07.1:
 * Environment variable CAMLP4LIB to change camlp4 library directory
 * Grammar: empty rules have a correct location instead of (-1, -1)
 * Compilation possible in Windows NT/95
-* String constants no more shared while parsing Ocaml
+* String constants no more shared while parsing OCaml
 * Fixed bug in antiquotations in q_MLast.cmo (bad errors locations)
 * Fixed bug in antiquotations in q_MLast.cmo (EOI not checked)
 * Fixed bug in Plexer: could not create keywords with iso 8859 characters
@@ -748,17 +748,17 @@ Camlp4 Version 1.07:
 * Added iso 8859 uppercase characters for uidents in plexer.ml
 * Fixed bug factorization IDENT in grammars
 * Fixed bug pr_o.cmo was printing "declare"
-* Fixed bug constructor arity in Ocaml syntax (pa_o.cmo).
+* Fixed bug constructor arity in OCaml syntax (pa_o.cmo).
 * Changed "lazy" into "slazy".
 * Completed pa_ifdef.cmo.
 
 Camlp4 Version 1.06:
 --------------------
 
-* Adapted to Ocaml 1.06.
-* Changed version number to match Ocaml's => 1.06 too.
-* Deleted module Gstream, using Ocaml's Stream.
-* Generate different AST for C(x,y) and C x y (change done in Ocaml's compiler)
+* Adapted to OCaml 1.06.
+* Changed version number to match OCaml's => 1.06 too.
+* Deleted module Gstream, using OCaml's Stream.
+* Generate different AST for C(x,y) and C x y (change done in OCaml's compiler)
 * No more message "Interrupted" in toplevel in case of syntax error.
 * Added flag to suppress warnings while extending grammars.
 * Completed some missing statements and declarations (objects)
@@ -832,7 +832,7 @@ Camlp4 Version 0.6:
     when the quotation is in a context of a pattern. These expanders,
     returning strings which are parsed afterwards, may work for some
     language syntax and/or language extensions used (e.g. may work for
-    Righteous syntax and not for Ocaml syntax).
+    Righteous syntax and not for OCaml syntax).
   - A new type of expander returning directly syntax trees. A pair
     of functions, for expressions and for patterns must be provided.
     These expanders are independant from the language syntax and/or
@@ -842,12 +842,12 @@ Camlp4 Version 0.6:
   been deleted; one can use "ctyp", "patt", and "expr" in position of
   pattern or expression.
 
---- Ocaml and Righteous syntaxes
+--- OCaml and Righteous syntaxes
 
 * Fixed bug: "open Foo.Bar" was converted (pr_dump.cmo) into "open Bar.Foo"
 
-* Corrected behavior different from Ocaml's: "^" and "@" were at the same
-  level than "=": now, like Ocaml, they have a separated right associative
+* Corrected behavior different from OCaml's: "^" and "@" were at the same
+  level than "=": now, like OCaml, they have a separated right associative
   level.
 
 --- Grammars behavior
@@ -881,7 +881,7 @@ Camlp4 Version 0.5:
 
 * Possible creation of native code library (make opt)
 
-* Ocaml and Righteous Syntax more complete
+* OCaml and Righteous Syntax more complete
 
 * Added pa_ru.cmo for compiling sequences of type unit (Righteous)
 

diff --git a/camlp4/Camlp4/.cvsignore b/camlp4/Camlp4/.cvsignore
deleted file mode 100644 (file)
index e69de29..0000000

diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml
index 8f62adf3b32be52be4380143c6acf5d8a011d5b8..228743734d9a6efe8945226f32d88f41a9d457ca 100644 (file)
--- a/camlp4/Camlp4/Camlp4Ast.partial.ml
+++ b/camlp4/Camlp4/Camlp4Ast.partial.ml
@@ -1,3 +1,20 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007   Institut National de Recherche  en  Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
+(* Note: when you modify these types you must increment
+   ast magic numbers defined in Camlp4_config.ml. *)
+
   type loc = Loc.t
    and meta_bool =
     [ BTrue
@@ -61,9 +78,12 @@
     | TyObj of loc and ctyp and row_var_flag
     | TyOlb of loc and string and ctyp (* ?s:t *)
     | TyPol of loc and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *)
+    | TyTypePol of loc and ctyp and ctyp (* type t . t *) (* type a . list a -> a *)
     | TyQuo of loc and string (* 's *)
     | TyQuP of loc and string (* +'s *)
     | TyQuM of loc and string (* -'s *)
+    | TyAnP of loc (* +_ *)
+    | TyAnM of loc (* -_ *)
     | TyVrn of loc and string (* `s *)
     | TyRec of loc and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *)
     | TyCol of loc and ctyp and ctyp (* t : t *)
@@ -116,7 +136,8 @@
     | PaTyc of loc and patt and ctyp (* (p : t) *)
     | PaTyp of loc and ident (* #i *)
     | PaVrn of loc and string (* `s *)
-    | PaLaz of loc and patt (* lazy p *) ]
+    | PaLaz of loc and patt (* lazy p *)
+    | PaMod of loc and string (* (module M) *) ]
   and expr =
     [ ExNil of loc
     | ExId  of loc and ident (* i *)

diff --git a/camlp4/Camlp4/Debug.ml b/camlp4/Camlp4/Debug.ml
index cbd30922768166ca78d08a0ec2bda45dd9072773..73a38db89f02421d174851a4399e34230f6798ab 100644 (file)
--- a/camlp4/Camlp4/Debug.ml
+++ b/camlp4/Camlp4/Debug.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -50,24 +50,15 @@ value mode =
 
 value formatter =
   let header = "camlp4-debug: " in
-  let normal s =
-    let rec self from accu =
-      try
-        let i = String.index_from s from '\n'
-        in self (i + 1) [String.sub s from (i - from + 1) :: accu]
-      with
-      [ Not_found -> [ String.sub s from (String.length s - from) :: accu ] ]
-    in String.concat header (List.rev (self 0 [])) in
-  let after_new_line str = header ^ normal str in
-  let f = ref after_new_line in
-  let output str chr = do {
-    output_string out_channel (f.val str);
-    output_char out_channel chr;
-    f.val := if chr = '\n' then after_new_line else normal;
-  } in
+  let at_bol = ref True in
   (make_formatter
     (fun buf pos len ->
-      let p = pred len in output (String.sub buf pos p) buf.[pos + p])
+       for i = pos to pos + len - 1 do
+         if at_bol.val then output_string out_channel header else ();
+         let ch = buf.[i];
+         output_char out_channel ch;
+         at_bol.val := ch = '\n';
+       done)
     (fun () -> flush out_channel));
 
 value printf section fmt = fprintf formatter ("%s: " ^^ fmt) section;

diff --git a/camlp4/Camlp4/Debug.mli b/camlp4/Camlp4/Debug.mli
index 13af7733916c5a806cd5b87f8421543b71d18080..97597f9c04f4daec7f0101d6b78a296fd8f28524 100644 (file)
--- a/camlp4/Camlp4/Debug.mli
+++ b/camlp4/Camlp4/Debug.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/ErrorHandler.ml b/camlp4/Camlp4/ErrorHandler.ml
index 231efed90402425445e550757fef6626181c8b21..bfefa49ab2eccd4f58c0a20da31ed088b2073f92 100644 (file)
--- a/camlp4/Camlp4/ErrorHandler.ml
+++ b/camlp4/Camlp4/ErrorHandler.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -92,7 +92,7 @@ module ObjTools = struct
       | x when x = Obj.string_tag ->
               "\"" ^ String.escaped (Obj.magic r : string) ^ "\""
       | x when x = Obj.double_tag ->
-              string_of_float (Obj.magic r : float)
+              Camlp4_import.Oprint.float_repres (Obj.magic r : float)
       | x when x = Obj.abstract_tag ->
               opaque "abstract"
       | x when x = Obj.custom_tag ->

diff --git a/camlp4/Camlp4/ErrorHandler.mli b/camlp4/Camlp4/ErrorHandler.mli
index 674811459b90b844ad499634b4634ef2c276506e..d73238df0f3fd5504bb2e576d66c5f3f707a631d 100644 (file)
--- a/camlp4/Camlp4/ErrorHandler.mli
+++ b/camlp4/Camlp4/ErrorHandler.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/OCamlInitSyntax.ml b/camlp4/Camlp4/OCamlInitSyntax.ml
index 85f8915f297a7181776a2c432843f15b477f9022..c424bfa72c3fab1baa28f57ede7e8e647c3c69eb 100644 (file)
--- a/camlp4/Camlp4/OCamlInitSyntax.ml
+++ b/camlp4/Camlp4/OCamlInitSyntax.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Options.ml b/camlp4/Camlp4/Options.ml
index e9979beeb4bfe08b6b61abf433916e0ed435dbbc..20503b4088388eeff493080755603eefa12e9d0a 100644 (file)
--- a/camlp4/Camlp4/Options.ml
+++ b/camlp4/Camlp4/Options.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Options.mli b/camlp4/Camlp4/Options.mli
index caffd8c2126fea15ae889daf7769ada6edde3467..2deb878d52efd4eaaf637cc8376572922ab03067 100644 (file)
--- a/camlp4/Camlp4/Options.mli
+++ b/camlp4/Camlp4/Options.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/PreCast.ml b/camlp4/Camlp4/PreCast.ml
index 8e3da3483d9f51c0e503e16571525c595b5877f2..169748519b85939ecb6d13d9a239d0702b1aabfc 100644 (file)
--- a/camlp4/Camlp4/PreCast.ml
+++ b/camlp4/Camlp4/PreCast.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/PreCast.mli b/camlp4/Camlp4/PreCast.mli
index 1c6eb2e989b1ef382a84f145214dfda36e9b7f81..a7dad534c5e1034ba0f868746e3f53984f36aa4a 100644 (file)
--- a/camlp4/Camlp4/PreCast.mli
+++ b/camlp4/Camlp4/PreCast.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml
index bd220c16d3bf26394a5e96ba1d15bfe80d7052b6..5b34e994d6f0ef7741e8d01982eeb5a5c3f2df45 100644 (file)
--- a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml
+++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli b/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli
index d35642ab4111a7c0bec2dd42da7ed0e6532001c4..5a0eb96f61eac9fd4c1ecb03966bbf5d3bf3c2b3 100644 (file)
--- a/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli
+++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.ml b/camlp4/Camlp4/Printers/DumpOCamlAst.ml
index dd6c60f6f98247c7e74dc52abdc3f6da67790394..57d2a15e2428583bb9e5acd4424b0f603ff95b86 100644 (file)
--- a/camlp4/Camlp4/Printers/DumpOCamlAst.ml
+++ b/camlp4/Camlp4/Printers/DumpOCamlAst.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.mli b/camlp4/Camlp4/Printers/DumpOCamlAst.mli
index 3233557d0607e256db327d453c3e12cb3976f309..16eafbdb03f64952e7b4b441fe787fd63c697726 100644 (file)
--- a/camlp4/Camlp4/Printers/DumpOCamlAst.mli
+++ b/camlp4/Camlp4/Printers/DumpOCamlAst.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/Null.ml b/camlp4/Camlp4/Printers/Null.ml
index a9a2c486b825b7861f4e6d34416ea7f7ce100150..3b3b95490c5bd425ab3997802ebf3e40d0f61acc 100644 (file)
--- a/camlp4/Camlp4/Printers/Null.ml
+++ b/camlp4/Camlp4/Printers/Null.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/Null.mli b/camlp4/Camlp4/Printers/Null.mli
index d77151177b4896ac5a4519b71e911b53c1bd34d2..f81ce613799e5b7477a32e05a5a13452508c6e26 100644 (file)
--- a/camlp4/Camlp4/Printers/Null.mli
+++ b/camlp4/Camlp4/Printers/Null.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml
index 06765691fdb17e5e13ea7a3bb6d7b12f3aac9e17..def7f196a25302b5d02a2839ea1a74d98ba27e27 100644 (file)
--- a/camlp4/Camlp4/Printers/OCaml.ml
+++ b/camlp4/Camlp4/Printers/OCaml.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -106,10 +106,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
           "Cannot print %S this identifier does not respect OCaml lexing rules (%s)"
           str (Lexer.Error.to_string exn)) ];
 
-  value ocaml_char =
-    fun
-    [ "'" -> "\\'"
-    | c -> c ];
+  value ocaml_char x = x;
 
   value rec get_expr_args a al =
     match a with
@@ -371,7 +368,12 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
       match Ast.list_of_ctyp t [] with
       [ [] -> ()
       | ts ->
-          pp f "@[<hv0>| %a@]" (list o#ctyp "@ | ") ts ];
+          pp f "@[<hv0>| %a@]" (list o#constructor_declaration "@ | ") ts ];
+
+    method private constructor_declaration f t =
+      match t with
+      [ <:ctyp< $t1$ : $t2$ -> $t3$ >> -> pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 o#constructor_type t2 o#ctyp t3
+      | t -> o#ctyp f t ];
 
     method string f = pp f "%s";
     method quoted_string f = pp f "%S";
@@ -554,7 +556,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     | <:expr< $int64:s$ >> -> o#numeric f s "L"
     | <:expr< $int32:s$ >> -> o#numeric f s "l"
     | <:expr< $flo:s$ >> -> o#numeric f s ""
-    | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s)
+    | <:expr< $chr:s$ >> -> pp f "'%s'" s
     | <:expr< $id:i$ >> -> o#var_ident f i
     | <:expr< { $b$ } >> ->
         pp f "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b
@@ -654,6 +656,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     | <:patt< $id:i$ >> -> o#var_ident f i
     | <:patt< $anti:s$ >> -> o#anti f s
     | <:patt< _ >> -> pp f "_"
+    | <:patt< ( module $m$ ) >> -> pp f "(module %s)" m
     | <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p
     | <:patt< { $p$ } >> -> pp f "@[<hv2>{@ %a@]@ }" o#patt p
     | <:patt< $str:s$ >> -> pp f "\"%s\"" s
@@ -663,7 +666,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     | <:patt< $int32:s$ >> -> o#numeric f s "l"
     | <:patt< $int:s$ >> -> o#numeric f s ""
     | <:patt< $flo:s$ >> -> o#numeric f s ""
-    | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s)
+    | <:patt< $chr:s$ >> -> pp f "'%s'" s
     | <:patt< ~ $s$ >> -> pp f "~%s" s
     | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s
     | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i
@@ -695,6 +698,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     [ <:ctyp< $id:i$ >> -> o#ident f i
     | <:ctyp< $anti:s$ >> -> o#anti f s
     | <:ctyp< _ >> -> pp f "_"
+    | Ast.TyAnP _ -> pp f "+_"
+    | Ast.TyAnM _ -> pp f "-_"
     | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t
     | <:ctyp< ? $s$ : $t$ >> -> pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t
     | <:ctyp< < > >> -> pp f "< >"
@@ -758,6 +763,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     | <:ctyp< ! $t1$ . $t2$ >> ->
         let (a, al) = get_ctyp_args t1 [] in
         pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2
+    | Ast.TyTypePol (_,t1,t2) ->
+        let (a, al) = get_ctyp_args t1 [] in
+        pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2
     | <:ctyp< private $t$ >> -> pp f "@[private@ %a@]" o#simple_ctyp t
     | t -> o#simple_ctyp f t ];
 
@@ -878,7 +886,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     let () = o#node f mt Ast.loc_of_module_type in
     match mt with
     [ <:module_type<>> -> assert False
-    | <:module_type< module type of $me$ >> -> pp f "@[<2>module type of@ %a@]" o#module_expr me
+    | <:module_type< module type of $me$ >> ->
+        pp f "@[<2>module type of@ %a@]" o#module_expr me
     | <:module_type< $id:i$ >> -> o#ident f i
     | <:module_type< $anti:s$ >> -> o#anti f s
     | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> ->
@@ -939,7 +948,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
     let () = o#node f ce Ast.loc_of_class_expr in
     match ce with
     [ <:class_expr< $ce$ $e$ >> ->
-          pp f "@[<2>%a@ %a@]" o#class_expr ce o#expr e
+          pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e
     | <:class_expr< $id:i$ >> ->
           pp f "@[<2>%a@]" o#ident i
     | <:class_expr< $id:i$ [ $t$ ] >> ->

diff --git a/camlp4/Camlp4/Printers/OCaml.mli b/camlp4/Camlp4/Printers/OCaml.mli
index 1ec7120b919a57e5b74403540d73f474411cbc1b..0d36742bf46e685e63ea9589e4d27f858052165d 100644 (file)
--- a/camlp4/Camlp4/Printers/OCaml.mli
+++ b/camlp4/Camlp4/Printers/OCaml.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml
index 199458792714278df49b3da33972ac6d1d8ae365..b91f8ea7c9007269d372908810f6fde8bdc0385b 100644 (file)
--- a/camlp4/Camlp4/Printers/OCamlr.ml
+++ b/camlp4/Camlp4/Printers/OCamlr.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Printers/OCamlr.mli b/camlp4/Camlp4/Printers/OCamlr.mli
index f1db176a54adade844588f47d73355c27f35218d..45fcbdef5a27311d861702cd0ca95546178add41 100644 (file)
--- a/camlp4/Camlp4/Printers/OCamlr.mli
+++ b/camlp4/Camlp4/Printers/OCamlr.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Register.ml b/camlp4/Camlp4/Register.ml
index e286eafb9c3c58402af2a65590001d5f3d20f344..010a831092488df026d4e230d830202be43234af 100644 (file)
--- a/camlp4/Camlp4/Register.ml
+++ b/camlp4/Camlp4/Register.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Register.mli b/camlp4/Camlp4/Register.mli
index bd8e13a1eec5e5bda23dad9b024283d30ca20fe6..d997d417b9f992ef22ec8233bb64a2b629e0c748 100644 (file)
--- a/camlp4/Camlp4/Register.mli
+++ b/camlp4/Camlp4/Register.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml
index 1664be75b02078eff7a6df2b62258efae2dcd393..bae3da5ad1db3b0999b536ad6f552d1ef5c71b5e 100644 (file)
--- a/camlp4/Camlp4/Sig.ml
+++ b/camlp4/Camlp4/Sig.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -64,6 +64,16 @@ end;
 (** A signature for locations. *)
 module type Loc = sig
 
+  (** The type of locations.  Note that, as for OCaml locations,
+      character numbers in locations refer to character numbers in the
+      parsed character stream, while line numbers refer to line
+      numbers in the source file. The source file and the parsed
+      character stream differ, for instance, when the parsed character
+      stream contains a line number directive. The line number
+      directive will only update the file-name field and the
+      line-number field of the position. It makes therefore no sense
+      to use character numbers with the source file if the sources
+      contain line number directives. *)
   type t;
 
   (** Return a start location for the given file name.
@@ -96,7 +106,8 @@ module type Loc = sig
       stop_line,  stop_bol,  stop_off, ghost)]. *)
   value to_tuple : t -> (string * int * int * int * int * int * int * bool);
 
-  (** [merge loc1 loc2] Return a location that starts at [loc1] and end at [loc2]. *)
+  (** [merge loc1 loc2] Return a location that starts at [loc1] and end at
+      [loc2]. *)
   value merge : t -> t -> t;
 
   (** The stop pos becomes equal to the start pos. *)
@@ -128,19 +139,19 @@ module type Loc = sig
   (** Return the line number of the ending of this location. *)
   value stop_line  : t -> int;
 
-  (** Returns the number of characters from the begining of the file
+  (** Returns the number of characters from the begining of the stream
       to the begining of the line of location's begining. *)
   value start_bol  : t -> int;
 
-  (** Returns the number of characters from the begining of the file
+  (** Returns the number of characters from the begining of the stream
       to the begining of the line of location's ending. *)
   value stop_bol   : t -> int;
 
-  (** Returns the number of characters from the begining of the file
+  (** Returns the number of characters from the begining of the stream
       of the begining of this location. *)
   value start_off  : t -> int;
 
-  (** Return the number of characters from the begining of the file
+  (** Return the number of characters from the begining of the stream
       of the ending of this location. *)
   value stop_off   : t -> int;
 
@@ -843,7 +854,7 @@ module type Token = sig
   module Error : Error;
 end;
 
-(** This signature describes tokens for the Objective Caml and the Revised
+(** This signature describes tokens for the OCaml and the Revised
     syntax lexing rules. For some tokens the data constructor holds two
     representations with the evaluated one and the source one. For example
     the INT data constructor holds an integer and a string, this string can

diff --git a/camlp4/Camlp4/Struct/.cvsignore b/camlp4/Camlp4/Struct/.cvsignore
deleted file mode 100644 (file)
index 262784d..0000000
--- a/camlp4/Camlp4/Struct/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-Lexer.ml
-Camlp4Ast.tmp.ml

diff --git a/camlp4/Camlp4/Struct/.ignore b/camlp4/Camlp4/Struct/.ignore
new file mode 100644 (file)
index 0000000..262784d
--- /dev/null
+++ b/camlp4/Camlp4/Struct/.ignore
@@ -0,0 +1,2 @@
+Lexer.ml
+Camlp4Ast.tmp.ml

diff --git a/camlp4/Camlp4/Struct/AstFilters.ml b/camlp4/Camlp4/Struct/AstFilters.ml
index 665e610affacfe12f4860513d05d47ef0fcd85a8..6474ba8e5cd6e6deb64f3d0ab8d8a9ab1e4a3d79 100644 (file)
--- a/camlp4/Camlp4/Struct/AstFilters.ml
+++ b/camlp4/Camlp4/Struct/AstFilters.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/camlp4/Camlp4/Struct/Camlp4Ast.mlast
index 6c4ea3bc8ac405612c8825cab76ff8d38f32e0f8..9c5a99752b8ba5f31c3632a605e847a7ff2754fc 100644 (file)
--- a/camlp4/Camlp4/Struct/Camlp4Ast.mlast
+++ b/camlp4/Camlp4/Struct/Camlp4Ast.mlast
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -123,6 +123,7 @@ module Make (Loc : Sig.Loc)
     | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
     | <:patt< lazy $p$ >> -> is_irrefut_patt p
     | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *)
+    | <:patt< (module $_$) >> -> True
     | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> |
       <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> |
       <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> |

diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index 92c64eb8b4794d72447a311ab737fcc724f9c49b..e73e875ff9727fcd81777335f5723e338163b0ae 100644 (file)
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -133,7 +133,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct
 
     let rec self i acc =
       match i with
-      [ <:ident< $i1$.$i2$ >> ->
+      [ <:ident< $lid:"*predef*"$.$lid:"option"$ >> ->
+          (ldot (lident "*predef*") "option", `lident)
+      | <:ident< $i1$.$i2$ >> ->
           self i2 (Some (self i1 acc))
       | <:ident< $i1$ $i2$ >> ->
           let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in
@@ -204,6 +206,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | <:ctyp< '$s$ >> -> [s]
     | _ -> assert False ];
 
+  value predef_option loc =
+    TyId (loc, IdAcc (loc, IdLid (loc, "*predef*"), IdLid (loc, "option")));
+
   value rec ctyp =
     fun
     [ TyId loc i ->
@@ -226,7 +231,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | TyArr loc (TyLab _ lab t1) t2 ->
         mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2))
     | TyArr loc (TyOlb loc1 lab t1) t2 ->
-        let t1 = TyApp loc1 <:ctyp@loc1< option >> t1 in
+        let t1 = TyApp loc1 (predef_option loc1) t1 in
         mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2))
     | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2))
     | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl []))
@@ -261,6 +266,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | TyAnt loc _ -> error loc "antiquotation not allowed here"
     | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ |
       TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ |
+         TyAnP _ | TyAnM _ | TyTypePol _ _ _ |
       TyObj _ _ (RvAnt _) | TyNil _ | TyTup _ _ ->
         assert False ]
   and row_field = fun
@@ -285,8 +291,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct
   and package_type_constraints wc acc =
     match wc with
     [ <:with_constr<>> -> acc
-    | <:with_constr< type $lid:id$ = $ct$ >> ->
-        [(id, ctyp ct) :: acc]
+    | <:with_constr< type $id:id$ = $ct$ >> ->
+        [(ident id, ctyp ct) :: acc]
     | <:with_constr< $wc1$ and $wc2$ >> ->
         package_type_constraints wc1 (package_type_constraints wc2 acc)
     | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ]
@@ -319,9 +325,14 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | _ -> assert False (*FIXME*) ];
   value mkvariant =
     fun
-    [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], mkloc loc)
+    [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], None, mkloc loc)
     | <:ctyp@loc< $uid:s$ of $t$ >> ->
-        (conv_con s, List.map ctyp (list_of_ctyp t []), mkloc loc)
+        (conv_con s, List.map ctyp (list_of_ctyp t []), None, mkloc loc)
+    | <:ctyp@loc< $uid:s$ : ($t$ -> $u$) >> ->
+        (conv_con s, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc)
+    | <:ctyp@loc< $uid:s$ : $t$ >> ->
+        (conv_con s, [], Some (ctyp t), mkloc loc)
+
     | _ -> assert False (*FIXME*) ];
   value rec type_decl tl cl loc m pflag =
     fun
@@ -346,7 +357,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
         mktype loc tl cl Ptype_abstract (mkprivate' pflag) m ]
   ;
 
-  value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t;
+  value type_decl tl cl t loc = type_decl tl cl loc None False t;
 
   value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};
 
@@ -381,6 +392,17 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc]
     | _ -> assert False ];
 
+  value rec optional_type_parameters t acc =
+    match t with
+    [ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc)
+    | <:ctyp< +'$s$ >> -> [(Some s, (True, False)) :: acc]
+    | Ast.TyAnP _loc  -> [(None, (True, False)) :: acc]
+    | <:ctyp< -'$s$ >> -> [(Some s, (False, True)) :: acc]
+    | Ast.TyAnM _loc -> [(None, (False, True)) :: acc]
+    | <:ctyp< '$s$ >> -> [(Some s, (False, False)) :: acc]
+    | Ast.TyAny _loc -> [(None, (False, False)) :: acc]
+    | _ -> assert False ];
+
   value rec class_parameters t acc =
     match t with
     [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc)
@@ -393,7 +415,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     match t with
     [ <:ctyp< $t1$ $t2$ >> ->
         type_parameters_and_type_name t1
-          (type_parameters t2 acc)
+          (optional_type_parameters t2 acc)
     | <:ctyp< $id:i$ >> -> (ident i, acc)
     | _ -> assert False ];
 
@@ -536,8 +558,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern"
     | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t))
     | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i))
-    | PaVrn loc s -> mkpat loc (Ppat_variant s None)
+    | PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None)
     | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p))
+    | PaMod loc m -> mkpat loc (Ppat_unpack m)
     | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p ->
         error (loc_of_patt p) "invalid pattern" ]
   and mklabpat =
@@ -589,6 +612,55 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     [ <:ctyp<>> -> acc
     | t -> list_of_ctyp t acc ];
 
+value varify_constructors var_names = 
+  let rec loop t = 
+    let desc = 
+      match t.ptyp_desc with
+         [
+       Ptyp_any -> Ptyp_any
+      | Ptyp_var x -> Ptyp_var x
+      | Ptyp_arrow label core_type core_type' ->
+         Ptyp_arrow label (loop core_type) (loop core_type')
+      | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+      | Ptyp_constr (Lident s) [] when List.mem s var_names ->
+         Ptyp_var ("&" ^ s)
+      | Ptyp_constr longident lst ->
+         Ptyp_constr longident (List.map loop lst) 
+      | Ptyp_object lst ->
+         Ptyp_object (List.map loop_core_field lst)                
+      | Ptyp_class longident lst lbl_list ->
+         Ptyp_class (longident, List.map loop lst, lbl_list) 
+      | Ptyp_alias core_type string ->
+         Ptyp_alias(loop core_type, string) 
+      | Ptyp_variant row_field_list flag lbl_lst_option -> 
+         Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) 
+      | Ptyp_poly string_lst core_type ->
+         Ptyp_poly(string_lst, loop core_type) 
+      | Ptyp_package longident lst ->
+         Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+]
+    in
+    {(t) with ptyp_desc = desc}
+  and loop_core_field t = 
+    let desc = 
+      match t.pfield_desc with
+      [ Pfield(n,typ) ->
+         Pfield(n,loop typ)
+      | Pfield_var ->
+         Pfield_var]
+    in
+    { (t) with pfield_desc=desc}
+  and loop_row_field x  = 
+    match x with
+      [ Rtag(label,flag,lst) ->
+         Rtag(label,flag,List.map loop lst) 
+      | Rinherit t ->
+         Rinherit (loop t) ]
+  in
+  loop;
+
+
+
   value rec expr =
     fun
     [ <:expr@loc< $x$.val >> ->
@@ -769,16 +841,17 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | <:expr@loc< $uid:s$ >> ->
         (* let ca = constructors_arity () in *)
         mkexp loc (Pexp_construct (lident (conv_con s)) None True)
-    | ExVrn loc s -> mkexp loc (Pexp_variant s None)
+    | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None)
     | ExWhi loc e1 el ->
         let e2 = ExSeq loc el in
         mkexp loc (Pexp_while (expr e1) (expr e2))
     | <:expr@loc< let open $i$ in $e$ >> ->
         mkexp loc (Pexp_open (long_uident i) (expr e))
     | <:expr@loc< (module $me$ : $pt$) >> ->
-        mkexp loc (Pexp_pack (module_expr me) (package_type pt))
-    | <:expr@loc< (module $_$) >> ->
-        error loc "(module_expr : package_type) expected here"
+        mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)),
+                    Some (mktyp loc (Ptyp_package (package_type pt))), None))
+    | <:expr@loc< (module $me$) >> ->
+        mkexp loc (Pexp_pack (module_expr me))
     | ExFUN loc i e ->
         mkexp loc (Pexp_newtype i (expr e))
     | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here"
@@ -802,6 +875,32 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     match x with
     [ <:binding< $x$ and $y$ >> ->
          binding x (binding y acc)
+    | <:binding@_loc< $lid:bind_name$ = ($e$ : $TyTypePol _ vs ty$) >> ->
+      (* this code is not pretty because it is temporary *)
+      let rec id_to_string x = 
+       match x with 
+           [ <:ctyp< $lid:x$ >> -> [x]
+           | <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y)
+           | _ -> assert False]
+      in
+      let vars = id_to_string vs in
+      let ampersand_vars = List.map (fun x -> "&" ^ x) vars in
+      let ty' = varify_constructors vars (ctyp ty) in
+      let mkexp = mkexp _loc in
+      let mkpat = mkpat _loc in
+      let e = mkexp (Pexp_constraint (expr e) (Some (ctyp ty)) None) in
+      let rec mk_newtypes x = 
+       match x with
+         [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e))
+         | [newtype :: newtypes] ->
+           mkexp(Pexp_newtype (newtype,mk_newtypes newtypes))
+         | [] -> assert False]
+      in
+      let pat = 
+       mkpat (Ppat_constraint (mkpat (Ppat_var bind_name), mktyp _loc (Ptyp_poly ampersand_vars ty')))
+      in
+      let e = mk_newtypes vars in
+      [( pat, e) :: acc]
     | <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> ->
         [(patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>, expr e) :: acc]
     | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: acc]
@@ -835,7 +934,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     match x with
     [ <:ctyp< $x$ and $y$ >> ->
          mktype_decl x (mktype_decl y acc)
-    | Ast.TyDcl _ c tl td cl ->
+    | Ast.TyDcl loc c tl td cl ->
         let cl =
           List.map
             (fun (t1, t2) ->
@@ -843,7 +942,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
               (ctyp t1, ctyp t2, mkloc loc))
             cl
         in
-        [(c, type_decl (List.fold_right type_parameters tl []) cl td) :: acc]
+        [(c, type_decl (List.fold_right optional_type_parameters tl []) cl td loc) :: acc]
     | _ -> assert False ]
   and module_type =
     fun
@@ -920,9 +1019,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | <:module_expr@loc< ($me$ : $mt$) >> ->
         mkmod loc (Pmod_constraint (module_expr me) (module_type mt))
     | <:module_expr@loc< (value $e$ : $pt$) >> ->
-        mkmod loc (Pmod_unpack (expr e) (package_type pt))
-    | <:module_expr@loc< (value $_$) >> ->
-        error loc "(value expr) not supported yet"
+        mkmod loc (Pmod_unpack (
+                   mkexp loc (Pexp_constraint (expr e,
+                              Some (mktyp loc (Ptyp_package (package_type pt))),
+                              None))))
+    | <:module_expr@loc< (value $e$) >> ->
+        mkmod loc (Pmod_unpack (expr e))
     | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ]
   and str_item s l =
     match s with
@@ -942,6 +1044,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct
                       (List.map ctyp (list_of_ctyp t []))) :: l ]
     | <:str_item@loc< exception $uid:s$ = $i$ >> ->
         [mkstr loc (Pstr_exn_rebind (conv_con s) (ident i)) :: l ]
+    | <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> ->
+        error loc "type in exception alias"
     | StExc _ _ _ -> assert False (*FIXME*)
     | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l]
     | StExt loc n t sl -> [mkstr loc (Pstr_primitive n (mkvalue_desc t (list_of_meta_list sl))) :: l]
@@ -964,7 +1068,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
     | CtFun loc (TyLab _ lab t) ct ->
         mkcty loc (Pcty_fun lab (ctyp t) (class_type ct))
     | CtFun loc (TyOlb loc1 lab t) ct ->
-        let t = TyApp loc1 <:ctyp@loc1< option >> t in
+        let t = TyApp loc1 (predef_option loc1) t in
         mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct))
     | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct))
     | CtSig loc t_o ctfl ->

diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli
index 6c284833237a5a7008fe6345b18441276e7f189b..0e6f52cc9f48b277adf75dfd991613b157e1419f 100644 (file)
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/CleanAst.ml b/camlp4/Camlp4/Struct/CleanAst.ml
index ab9250543c07541a0f5de80fe6491343bb815e65..8354d1c23bffa69611944e22e6af9063627479f8 100644 (file)
--- a/camlp4/Camlp4/Struct/CleanAst.ml
+++ b/camlp4/Camlp4/Struct/CleanAst.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/CommentFilter.ml b/camlp4/Camlp4/Struct/CommentFilter.ml
index 9dac53fbf78511eb68c76a9cb5ac1791a1e8df9d..f8cb3004d7cdfe8f8304fe0c3caff58fc715f19d 100644 (file)
--- a/camlp4/Camlp4/Struct/CommentFilter.ml
+++ b/camlp4/Camlp4/Struct/CommentFilter.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/CommentFilter.mli b/camlp4/Camlp4/Struct/CommentFilter.mli
index 79ece6a4c755a13b50ffdd09a2f4c06e3dfd59c0..1df29f7bb576aa26ef94bc506d810baa6dfc9e17 100644 (file)
--- a/camlp4/Camlp4/Struct/CommentFilter.mli
+++ b/camlp4/Camlp4/Struct/CommentFilter.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/DynAst.ml b/camlp4/Camlp4/Struct/DynAst.ml
index 2161e1c91c9ec567614d414807544bdf6b87c59c..4bc8a33b7e1de65a194fb081545a9e4c5ec8462c 100644 (file)
--- a/camlp4/Camlp4/Struct/DynAst.ml
+++ b/camlp4/Camlp4/Struct/DynAst.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/DynLoader.ml b/camlp4/Camlp4/Struct/DynLoader.ml
index f8e8c22fdff56a062177805ca16a18a4f9b0fc90..00ab05ab3f6ef8a9c96574ba7ad9bb787195de48 100644 (file)
--- a/camlp4/Camlp4/Struct/DynLoader.ml
+++ b/camlp4/Camlp4/Struct/DynLoader.ml
@@ -1,15 +1,15 @@
 (* camlp4r pa_macro.cmo *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2001-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/DynLoader.mli b/camlp4/Camlp4/Struct/DynLoader.mli
index 292b705b579567ba502823298c85acdd9946d473..7a7dc899a094e4a93b670489fd069e4b09f40336 100644 (file)
--- a/camlp4/Camlp4/Struct/DynLoader.mli
+++ b/camlp4/Camlp4/Struct/DynLoader.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/EmptyError.ml b/camlp4/Camlp4/Struct/EmptyError.ml
index 1acb2251a9c68c94d287811764c8588efaf034cf..52a5028923cb809b2f2bf8a839918aae990a2a1c 100644 (file)
--- a/camlp4/Camlp4/Struct/EmptyError.ml
+++ b/camlp4/Camlp4/Struct/EmptyError.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -19,4 +19,4 @@
 type t = unit;
 exception E of t;
 value print _ = assert False;
-value to_string _ = assert False;
\ No newline at end of file
+value to_string _ = assert False;

diff --git a/camlp4/Camlp4/Struct/EmptyError.mli b/camlp4/Camlp4/Struct/EmptyError.mli
index 9d216623a42e1c841f42faf68d2375782e0aef27..076ee3170d4a01558433a53a1d71867bc6f89e4d 100644 (file)
--- a/camlp4/Camlp4/Struct/EmptyError.mli
+++ b/camlp4/Camlp4/Struct/EmptyError.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -16,4 +16,4 @@
  * - Daniel de Rauglaudre: initial version
  * - Nicolas Pouillard: refactoring
  *)
-include Sig.Error;
\ No newline at end of file
+include Sig.Error;

diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.ml b/camlp4/Camlp4/Struct/EmptyPrinter.ml
index 5886809b6b2907c06aaee1c883ecb4631dc62eb4..11a93cd689bb64d21ee3361b9a23b3eec6584308 100644 (file)
--- a/camlp4/Camlp4/Struct/EmptyPrinter.ml
+++ b/camlp4/Camlp4/Struct/EmptyPrinter.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.mli b/camlp4/Camlp4/Struct/EmptyPrinter.mli
index f8bf907ae565a8ebc49b118c8be8a4e06d67a3af..94585b329cd1b1875e0da04ebefe18a61e944c08 100644 (file)
--- a/camlp4/Camlp4/Struct/EmptyPrinter.mli
+++ b/camlp4/Camlp4/Struct/EmptyPrinter.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2006-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/FreeVars.ml b/camlp4/Camlp4/Struct/FreeVars.ml
index 69e9030367468e3258cca992337b54613cf2c50d..8c253ff50dd0a3847c15b7e5321e7276a9a44434 100644 (file)
--- a/camlp4/Camlp4/Struct/FreeVars.ml
+++ b/camlp4/Camlp4/Struct/FreeVars.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/FreeVars.mli b/camlp4/Camlp4/Struct/FreeVars.mli
index aac72db05496255948a573c2451838885dfaca19..06d3cc0a9b4389ef98a609bc55b2195c8053c95f 100644 (file)
--- a/camlp4/Camlp4/Struct/FreeVars.mli
+++ b/camlp4/Camlp4/Struct/FreeVars.mli
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Delete.ml b/camlp4/Camlp4/Struct/Grammar/Delete.ml
index 929ac2b4eaefeed90dadfc8f6d5d97dffe1b7676..d8f9f9aa4294f2733034d26d605072dd2071b770 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Delete.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Delete.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Dynamic.ml b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml
index 7889cf0712797c88279b93f0f8d0b418e752b582..06ac28f1f82c8d26ba9c456d8ec1b99225d6d0c4 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Dynamic.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Entry.ml b/camlp4/Camlp4/Struct/Grammar/Entry.ml
index 0b39b7ca6cf3f893de3269a638e2ac78d338a291..4ab0c89603931da0629b9910a184ce34f08e0040 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Entry.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Entry.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Failed.ml b/camlp4/Camlp4/Struct/Grammar/Failed.ml
index b22998bd4827fe34552e2258242e28abcba450f8..a0327b152c278640facdae0344b3f869fb31ce7f 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Failed.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Failed.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Find.ml b/camlp4/Camlp4/Struct/Grammar/Find.ml
index 9e7774d15285fd4cd359f39594917b386930d75b..82bd2f0ed3d6f65651768b777c258baba9cada1e 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Find.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Find.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Fold.ml b/camlp4/Camlp4/Struct/Grammar/Fold.ml
index caf8a7a0a34270683af7c64bc58db31dfcca4c5f..99e095505804b4d67230d6f19f2c5437f7a7ab43 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Fold.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Fold.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Fold.mli b/camlp4/Camlp4/Struct/Grammar/Fold.mli
index 0b9b22b7912959ea8acbb2fa21b4c935eaefe4df..1578ccbd029efc3ac69a538f2345d223d860aa9c 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Fold.mli
+++ b/camlp4/Camlp4/Struct/Grammar/Fold.mli
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Insert.ml b/camlp4/Camlp4/Struct/Grammar/Insert.ml
index a6cbf0eeed7833455074c1039b80c03e91974d45..24deb01f588c0db606fdbf24eb6c6840219be8b4 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Insert.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Insert.ml
@@ -1,15 +1,15 @@
 (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -256,10 +256,6 @@ module Make (Structure : Structure.S) = struct
                 Some t
             | None -> None ]
       | LocAct _ _ | DeadEnd -> None ]
-    and insert_new =
-      fun
-      [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd}
-      | [] -> LocAct action [] ]
     in
     insert gsymbols tree
   ;

diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.ml b/camlp4/Camlp4/Struct/Grammar/Parser.ml
index 89bbe884dfc8455f3715d9b28bd98378e204b4eb..2c639b2a1c7af97b2eecf3346529eb02e37cdc9e 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Parser.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Parser.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -34,9 +34,17 @@ module Make (Structure : Structure.S) = struct
   value drop_prev_loc = Tools.drop_prev_loc;
 
   value add_loc bp parse_fun strm =
+    let count1 = Stream.count strm in
     let x = parse_fun strm in
-    let ep = loc_ep strm in
-    let loc = Loc.merge bp ep in
+    let count2 = Stream.count strm in
+    let loc =
+      if count1 < count2 then
+        let ep = loc_ep strm in
+        Loc.merge bp ep
+      else
+        (* If nothing has been consumed, create a 0-length location. *)
+        Loc.join bp
+    in
     (x, loc);
 
   value stream_peek_nth strm n =

diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.mli b/camlp4/Camlp4/Struct/Grammar/Parser.mli
index 7b7cbe5a2bba01a2d369417291083d12ed707b6f..74e0fe07d74934999e74587809c9d98ce5fda883 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Parser.mli
+++ b/camlp4/Camlp4/Struct/Grammar/Parser.mli
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2007   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Print.ml b/camlp4/Camlp4/Struct/Grammar/Print.ml
index 77000c88aa33115e4dfbb4aa83a9e433caca537b..06e09c218800b1edf008301993e66c28b2a67b4c 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Print.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Print.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Print.mli b/camlp4/Camlp4/Struct/Grammar/Print.mli
index 9acc836de2d827477cdd0c0ddc08f23b01661008..b1059a6d9f4f947a825f0f83210b5d57150cc49a 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Print.mli
+++ b/camlp4/Camlp4/Struct/Grammar/Print.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Search.ml b/camlp4/Camlp4/Struct/Grammar/Search.ml
index bc4ed301adbb8113d93cfb5102f3d8431a419f8b..226a0d44e5ab5f59b19af160358f9c1e3c329a0d 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Search.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Search.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Static.ml b/camlp4/Camlp4/Struct/Grammar/Static.ml
index a94c9fa1c56488f81eb7703c32a39e22c9ab2762..02aec0b1713ae896de2290ffe8d6387e801ff70c 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Static.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Static.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Structure.ml b/camlp4/Camlp4/Struct/Grammar/Structure.ml
index 67b99feb996e934d3a7b5c30b533057edd1a8d63..e2a79b18be7f3484c047b874e1ca6f13e1255ea8 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Structure.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Structure.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Grammar/Tools.ml b/camlp4/Camlp4/Struct/Grammar/Tools.ml
index cb63478ad89d988d1969e0b4a19c00963453e20a..df4b03fe5545994c5efed558182df29727ee952a 100644 (file)
--- a/camlp4/Camlp4/Struct/Grammar/Tools.ml
+++ b/camlp4/Camlp4/Struct/Grammar/Tools.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll
index 1823ae0af45d36eaaf4da42a2662f1f4e1099356..c73369959ddc07f2a8bb9465e197762905c7fc35 100644 (file)
--- a/camlp4/Camlp4/Struct/Lexer.mll
+++ b/camlp4/Camlp4/Struct/Lexer.mll
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2006-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Loc.ml b/camlp4/Camlp4/Struct/Loc.ml
index ac42d4b1c4d70346bded2ae618dd3d7aedff29b0..2fd2c910670c9de9fe272acd8546a547070504ae 100644 (file)
--- a/camlp4/Camlp4/Struct/Loc.ml
+++ b/camlp4/Camlp4/Struct/Loc.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Loc.mli b/camlp4/Camlp4/Struct/Loc.mli
index e90161938c187009c910b73d0e054767493a4eda..c6c523fc5f16cd7ef51b8e1884d325924d208f06 100644 (file)
--- a/camlp4/Camlp4/Struct/Loc.mli
+++ b/camlp4/Camlp4/Struct/Loc.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Quotation.ml b/camlp4/Camlp4/Struct/Quotation.ml
index 65202c87512785b4971d22dceffbd74f82727cae..c9d6169a99d8e3848a7bdf10538a4710c4430173 100644 (file)
--- a/camlp4/Camlp4/Struct/Quotation.ml
+++ b/camlp4/Camlp4/Struct/Quotation.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Token.ml b/camlp4/Camlp4/Struct/Token.ml
index 384bba9116563ef4b6f30f6ea762b16a8153df23..2620729728a4c32edb92344e2b5913f2d48f975d 100644 (file)
--- a/camlp4/Camlp4/Struct/Token.ml
+++ b/camlp4/Camlp4/Struct/Token.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4/Struct/Token.mli b/camlp4/Camlp4/Struct/Token.mli
index 812df0e008e41c262895fea318d6a95129aa2fef..d3e866a337ba042e76320c17389e574012985fe0 100644 (file)
--- a/camlp4/Camlp4/Struct/Token.mli
+++ b/camlp4/Camlp4/Struct/Token.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml
index a123cc12f4a1874a900fdd807f175109b1a6d933..ecc64311f2cb0a99cde2e09740759d254b34fa40 100644 (file)
--- a/camlp4/Camlp4Bin.ml
+++ b/camlp4/Camlp4Bin.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Filters/Camlp4AstLifter.ml b/camlp4/Camlp4Filters/Camlp4AstLifter.ml
index 768e4dac9ed2654fdcefecc57481e1edaa9d375d..cc594aac8f02663873c7d243b1ad8076ba4306f6 100644 (file)
--- a/camlp4/Camlp4Filters/Camlp4AstLifter.ml
+++ b/camlp4/Camlp4Filters/Camlp4AstLifter.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml b/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml
index 3d338c41982af60deaed421796c49d0a128841d3..3cf570c07086f7fedf86e73b98e942011d60a4a2 100644 (file)
--- a/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml
+++ b/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml
index 66c48d7e54844df243d56bd3770abc61de2815f1..205afa927152f52668c4ba8aee69cb46f12785bf 100644 (file)
--- a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml
+++ b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
-(*  Copyright 2006,2007 Institut National de Recherche en Informatique et   *)
+(*  Copyright 2006-2007 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Filters/Camlp4LocationStripper.ml b/camlp4/Camlp4Filters/Camlp4LocationStripper.ml
index 533292de61051f77fad5a369cabef51a2dbbe48c..59199f888829e5d21a18d16cecc514385ff8dbab 100644 (file)
--- a/camlp4/Camlp4Filters/Camlp4LocationStripper.ml
+++ b/camlp4/Camlp4Filters/Camlp4LocationStripper.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Filters/Camlp4MapGenerator.ml b/camlp4/Camlp4Filters/Camlp4MapGenerator.ml
index 52b00eb6a99b624f193e2a55f9394c7535bac164..de1f910bf83bd9e2128d51c84cfef808d442b667 100644 (file)
--- a/camlp4/Camlp4Filters/Camlp4MapGenerator.ml
+++ b/camlp4/Camlp4Filters/Camlp4MapGenerator.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007   Institut National de Recherche  en  Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (* This module is useless now. Camlp4FoldGenerator handles map too. *)
 module Id = struct
   value name    = "Camlp4MapGenerator";

diff --git a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml
index a49cbf32ff346c7e00e898068f5abf25f4fa6eb7..b716d5afdc6e002b35ae0ecde0b01a874729bcf8 100644 (file)
--- a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml
+++ b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007   Institut National de Recherche  en  Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4;
 open PreCast;
 module MapTy = Map.Make String;

diff --git a/camlp4/Camlp4Filters/Camlp4Profiler.ml b/camlp4/Camlp4Filters/Camlp4Profiler.ml
index 1800851607ad1674c000df7e1a8dc4af2e4398e3..99335cc849c4c0623bf8e03a134c6bb63daf2b4c 100644 (file)
--- a/camlp4/Camlp4Filters/Camlp4Profiler.ml
+++ b/camlp4/Camlp4Filters/Camlp4Profiler.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Filters/Camlp4TrashRemover.ml b/camlp4/Camlp4Filters/Camlp4TrashRemover.ml
index 07ead66a83095596fae264203322c6a0bad259bc..d486e2b663075bf7da4bbc22ceb522d2b3c58173 100644 (file)
--- a/camlp4/Camlp4Filters/Camlp4TrashRemover.ml
+++ b/camlp4/Camlp4Filters/Camlp4TrashRemover.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright   2006    Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4AstLoader.ml b/camlp4/Camlp4Parsers/Camlp4AstLoader.ml
index 67d04edf94bfeac9deaee77b94dcdbfac22344c8..eb0a2139084ec263a02fa774cc987682e39f62ed 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4AstLoader.ml
+++ b/camlp4/Camlp4Parsers/Camlp4AstLoader.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4DebugParser.ml b/camlp4/Camlp4Parsers/Camlp4DebugParser.ml
index 7e722818810f6da8723d5638e2df3b304f6a9f05..be4fe60ac48b62fba7ccd21e0296ca97d1adcec2 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4DebugParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4DebugParser.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                             (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml
index 3d64b1ae38df309986d9ca319f7017f0e5cb6960..6b4e1d8e25a8f41421402bd4403a305b29475bd9 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                        (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml
index f5878fb989dae5092a51da51159dea1e586c0e1f..7bdad3c4ec2e33e665861e2fe40179b127558d32 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml
+++ b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                             (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml
index 0cb81be94564eb9f4e94dcd22244f68493593cca..840bc5ec1a52874ddb627cad77984e4374a2072c 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                             (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -52,6 +52,7 @@ Added statements:
      DEFINE <lident> = <expression> IN <expression>
      __FILE__
      __LOCATION__
+     LOCATION_OF <parameter>
 
   In patterns:
 
@@ -84,6 +85,10 @@ Added statements:
 
   The expression __FILE__ returns the current compiled file name.
   The expression __LOCATION__ returns the current location of itself.
+  If used inside a macro, it returns the location where the macro is
+  called.
+  The expression (LOCATION_OF parameter) returns the location of the given
+  macro parameter. It cannot be used outside a macro definition.
 
 *)
 
@@ -151,6 +156,15 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
       [ <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e ->
           try List.assoc x env with
           [ Not_found -> super#expr e ]
+      | <:expr@_loc< LOCATION_OF $lid:x$ >> | <:expr@_loc< LOCATION_OF $uid:x$ >> as e ->
+          try
+            let loc = Ast.loc_of_expr (List.assoc x env) in
+            let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc in
+            <:expr< Loc.of_tuple
+              ($`str:a$, $`int:b$, $`int:c$, $`int:d$,
+               $`int:e$, $`int:f$, $`int:g$,
+               $if h then <:expr< True >> else <:expr< False >> $) >>
+          with [ Not_found -> super#expr e ]
       | e -> super#expr e ];
 
     method patt =
@@ -387,15 +401,6 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
         | "DEFINE"; i = LIDENT; "="; def = expr; "IN"; body = expr ->
             (new subst _loc [(i, def)])#expr body ] ]
     ;
-    expr: LEVEL "simple"
-      [ [ LIDENT "__FILE__" -> <:expr< $`str:Loc.file_name _loc$ >>
-        | LIDENT "__LOCATION__" ->
-            let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in
-            <:expr< Loc.of_tuple
-                ($`str:a$, $`int:b$, $`int:c$, $`int:d$,
-                 $`int:e$, $`int:f$, $`int:g$,
-                 $if h then <:expr< True >> else <:expr< False >> $) >> ] ]
-    ;
     patt:
       [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; endif ->
             if is_defined i then p1 else p2
@@ -434,12 +439,20 @@ module MakeNothing (AstFilters : Camlp4.Sig.AstFilters) = struct
  open AstFilters;
  open Ast;
 
- value remove_nothings =
+ (* Remove NOTHING and expanse __FILE__ and __LOCATION__ *)
+ value map_expr =
    fun
    [ <:expr< $e$ NOTHING >> | <:expr< fun $ <:patt< NOTHING >> $ -> $e$ >> -> e
+   | <:expr@_loc< $lid:"__FILE__"$ >> -> <:expr< $`str:Loc.file_name _loc$ >>
+   | <:expr@_loc< $lid:"__LOCATION__"$ >> ->
+     let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in
+     <:expr< Loc.of_tuple
+       ($`str:a$, $`int:b$, $`int:c$, $`int:d$,
+        $`int:e$, $`int:f$, $`int:g$,
+        $if h then <:expr< True >> else <:expr< False >> $) >>
    | e -> e];
 
- register_str_item_filter (Ast.map_expr remove_nothings)#str_item;
+ register_str_item_filter (Ast.map_expr map_expr)#str_item;
 
 end;
 

diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml
index c033a22cb00c22e72e3dae1a4c0a4eb1fbfeaa20..eace67b4b953c4812b2a04c63b8dce399933ac1e 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                             (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml
index 0e0d989794d54e8955a6fdc4d875795fd9546d81..bbec29b966761ba1cbfb194f265b4a228bb710c4 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                        (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -158,6 +158,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
   DELETE_RULE Gram expr: SELF; ":="; SELF; dummy END;
   DELETE_RULE Gram expr: "~"; a_LIDENT; ":"; SELF END;
   DELETE_RULE Gram expr: "?"; a_LIDENT; ":"; SELF END;
+  DELETE_RULE Gram constructor_declarations: a_UIDENT; ":"; ctyp END;
   (* Some other DELETE_RULE are after the grammar *)
 
   value clear = Gram.Entry.clear;
@@ -384,6 +385,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
         | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >>
         | "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >>
         | "("; ")" -> <:patt< () >>
+        | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
+        | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
+            <:patt< ((module $m$) : (module $pt$)) >>
         | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
         | "("; p = patt; ")" -> <:patt< $p$ >>
         | "_" -> <:patt< _ >>
@@ -427,8 +431,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
       ] ]
     ;
     package_type_cstr:
-      [ [ "type"; i = a_LIDENT; "="; ty = ctyp ->
-            <:with_constr< type $lid:i$ = $ty$ >>
+      [ [ "type"; i = ident; "="; ty = ctyp ->
+            <:with_constr< type $id:i$ = $ty$ >>
       ] ]
     ;
     package_type_cstrs:
@@ -538,6 +542,15 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
         | t = ctyp LEVEL "ctyp1" -> t
       ] ]
     ;
+    constructor_declarations:
+      [ [ s = a_UIDENT; ":"; t = constructor_arg_list ; "->" ; ret = ctyp ->
+            <:ctyp< $uid:s$ : ($t$ -> $ret$) >>
+        | s = a_UIDENT; ":"; ret = constructor_arg_list ->
+           match Ast.list_of_ctyp ret [] with
+               [ [c] -> <:ctyp< $uid:s$ : $c$ >>
+               | _ -> raise (Stream.Error "invalid generalized constructor type") ]
+        ] ]
+    ;
     semi:
       [ [ ";;" -> () | -> () ] ]
     ;
@@ -559,17 +572,35 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
         | t = type_parameter -> fun acc -> <:ctyp< $acc$ $t$ >>
       ] ]
     ;
+
+    optional_type_parameter:
+      [ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >>
+        | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag
+        | "+"; "_" -> Ast.TyAnP _loc 
+        | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >>
+        | "-"; "_" -> Ast.TyAnM _loc
+        | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >>
+        | "_" -> Ast.TyAny _loc
+        | "'"; i = a_ident -> <:ctyp< '$lid:i$ >>
+
+ ] ]
+    ;
+
     type_ident_and_parameters:
-      [ [ "("; tpl = LIST1 type_parameter SEP ","; ")"; i = a_LIDENT -> (i, tpl)
-        | t = type_parameter; i = a_LIDENT -> (i, [t])
+      [ [ "("; tpl = LIST1 optional_type_parameter SEP ","; ")"; i = a_LIDENT -> (i, tpl)
+        | t = optional_type_parameter; i = a_LIDENT -> (i, [t])
         | i = a_LIDENT -> (i, [])
       ] ]
     ;
     type_kind:
       [ [ "private"; tk = type_kind -> <:ctyp< private $tk$ >>
-        | t = TRY [OPT "|"; t = constructor_declarations;
-                   test_not_dot_nor_lparen -> t] ->
-            <:ctyp< [ $t$ ] >>
+        | (x, t) = TRY [x = OPT "|"; t = constructor_declarations;
+                        test_not_dot_nor_lparen -> (x, t)] ->
+            (* If there is no "|" and [t] is an antiquotation,
+               then it is not a sum type. *)
+            match (x, t) with
+            [ (None, Ast.TyAnt _) -> t
+            | _ -> <:ctyp< [ $t$ ] >> ]
         | t = TRY ctyp -> <:ctyp< $t$ >>
         | t = TRY ctyp; "="; "private"; tk = type_kind ->
             <:ctyp< $t$ == private $tk$ >>

diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml
index 94a2bdb213e1a1d614616a6a5618364f1cd382c6..082ac836a5cbe24fd0eadfd045dbba2348204ef1 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 1998-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml
index e56ab361990d8fa3141de2dd61fcffecd6cdcecf..02c89f818d70ff6a2bdf467713200f0e197d258a 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                             (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
index b8eaf0bde547498036141b5ed6e2333960a28247..ed6dad0601cb9998ee47aae26baea88a1700d464 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                        (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -303,6 +303,15 @@ New syntax:\
   value stopped_at _loc =
     Some (Loc.move_line 1 _loc) (* FIXME be more precise *);
 
+  value rec generalized_type_of_type =
+    fun
+    [ <:ctyp< $t1$ -> $t2$ >> ->
+        let (tl, rt) = generalized_type_of_type t2 in
+        ([t1 :: tl], rt)
+    | t ->
+        ([], t) ]
+  ;
+
   value symbolchar =
     let list =
       ['$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?';
@@ -361,7 +370,7 @@ New syntax:\
     parser
     [ [: `((KEYWORD "(", _) as tok); xs :] ->
         match xs with parser
-        [ [: `(KEYWORD ("mod"|"land"|"lor"|"lxor"|"lsl"|"lsr"|"asr" as i), _loc);
+        [ [: `(KEYWORD ("or"|"mod"|"land"|"lor"|"lxor"|"lsl"|"lsr"|"asr" as i), _loc);
              `(KEYWORD ")", _); xs :] ->
                 [: `(LIDENT i, _loc); infix_kwds_filter xs :]
         | [: xs :] ->
@@ -521,7 +530,8 @@ New syntax:\
         | i = module_longident_with_app -> <:module_type< $id:i$ >>
         | "'"; i = a_ident -> <:module_type< ' $i$ >>
         | "("; mt = SELF; ")" -> <:module_type< $mt$ >>
-        | "module"; "type"; "of"; me = module_expr -> <:module_type< module type of $me$ >> ] ]
+        | "module"; "type"; "of"; me = module_expr ->
+            <:module_type< module type of $me$ >> ] ]
     ;
     sig_item:
       [ "top"
@@ -782,9 +792,9 @@ New syntax:\
       [ RIGHTA
         [ TRY ["("; "type"]; i = a_LIDENT; ")"; e = SELF ->
             <:expr< fun (type $i$) -> $e$ >>
-        | p = TRY labeled_ipatt; e = SELF ->
+        | bi = TRY cvalue_binding -> bi
+        | p = labeled_ipatt; e = SELF ->
             <:expr< fun $p$ -> $e$ >>
-        | bi = cvalue_binding -> bi
       ] ]
     ;
     match_case:
@@ -891,6 +901,9 @@ New syntax:\
         | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >>
         | "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >>
         | "("; ")" -> <:patt< () >>
+        | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
+        | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
+            <:patt< ((module $m$) : (module $pt$)) >>
         | "("; p = SELF; ")" -> p
         | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
         | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
@@ -959,6 +972,9 @@ New syntax:\
             <:patt< ($tup:<:patt< $anti:mk_anti ~c:"patt" n s$ >>$) >>
         | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.patt_tag
         | "("; ")" -> <:patt< () >>
+        | "("; "module"; m = a_UIDENT; ")" -> <:patt< (module $m$) >>
+        | "("; "module"; m = a_UIDENT; ":"; pt = package_type; ")" ->
+            <:patt< ((module $m$) : (module $pt$)) >>
         | "("; p = SELF; ")" -> p
         | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >>
         | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >>
@@ -977,6 +993,8 @@ New syntax:\
     ;
     label_ipatt_list:
       [ [ p1 = label_ipatt; ";"; p2 = SELF -> <:patt< $p1$ ; $p2$ >>
+        | p1 = label_ipatt; ";"; "_"       -> <:patt< $p1$ ; _ >>
+        | p1 = label_ipatt; ";"; "_"; ";"  -> <:patt< $p1$ ; _ >>
         | p1 = label_ipatt; ";"            -> p1
         | p1 = label_ipatt                 -> p1
       ] ];
@@ -1010,7 +1028,7 @@ New syntax:\
       [ [ t = ctyp -> t ] ]
     ;
     type_ident_and_parameters:
-      [ [ i = a_LIDENT; tpl = LIST0 type_parameter -> (i, tpl) ] ]
+      [ [ i = a_LIDENT; tpl = LIST0 optional_type_parameter -> (i, tpl) ] ]
     ;
     type_longident_and_parameters:
       [ [ i = type_longident; tpl = type_parameters -> tpl <:ctyp< $id:i$ >>
@@ -1023,6 +1041,7 @@ New syntax:\
         | -> fun t -> t
       ] ]
     ;
+
     type_parameter:
       [ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >>
         | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag
@@ -1030,6 +1049,20 @@ New syntax:\
         | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >>
         | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >> ] ]
     ;
+    optional_type_parameter:
+      [ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >>
+        | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag
+        | "'"; i = a_ident -> <:ctyp< '$lid:i$ >>
+        | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >>
+        | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >>
+        | "+"; "_" -> Ast.TyAnP _loc 
+        | "-"; "_" -> Ast.TyAnM _loc
+        | "_" -> Ast.TyAny _loc
+
+ ] ]
+    ;
+
+
     ctyp:
       [ "==" LEFTA
         [ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ]
@@ -1111,8 +1144,11 @@ New syntax:\
             <:ctyp< $t1$ | $t2$ >>
         | s = a_UIDENT; "of"; t = constructor_arg_list ->
             <:ctyp< $uid:s$ of $t$ >>
+        | s = a_UIDENT; ":"; t = ctyp ->
+            let (tl, rt) = generalized_type_of_type t in
+            <:ctyp< $uid:s$ : ($Ast.tyAnd_of_list tl$ -> $rt$) >>
         | s = a_UIDENT ->
-            <:ctyp< $uid:s$ >>
+         <:ctyp< $uid:s$ >>
       ] ]
     ;
     constructor_declaration:
@@ -1364,6 +1400,9 @@ New syntax:\
     ;
     cvalue_binding:
       [ [ "="; e = expr -> e
+        | ":"; "type"; t1 = unquoted_typevars; "." ; t2 = ctyp ; "="; e = expr -> 
+       let u = Ast.TyTypePol _loc t1 t2 in
+       <:expr< ($e$ : $u$) >>
         | ":"; t = poly_type; "="; e = expr -> <:expr< ($e$ : $t$) >>
         | ":"; t = poly_type; ":>"; t2 = ctyp; "="; e = expr ->
             match t with
@@ -1484,6 +1523,16 @@ New syntax:\
         | "'"; i = a_ident -> <:ctyp< '$lid:i$ >>
       ] ]
     ;
+    unquoted_typevars:
+      [ LEFTA
+        [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >>
+        | `ANTIQUOT (""|"typ" as n) s ->
+            <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >>
+        | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag
+        | i = a_ident -> <:ctyp< $lid:i$ >>
+      ] ]
+    ;
+
     row_field:
       [ [ `ANTIQUOT (""|"typ" as n) s ->
             <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >>
@@ -1741,13 +1790,19 @@ New syntax:\
     ;
     str_item_quot:
       [ [ "#"; n = a_LIDENT; dp = opt_expr -> <:str_item< # $n$ $dp$ >>
-        | st1 = str_item; semi; st2 = SELF -> <:str_item< $st1$; $st2$ >>
+        | st1 = str_item; semi; st2 = SELF ->
+            match st2 with
+            [ <:str_item<>> -> st1
+            | _ -> <:str_item< $st1$; $st2$ >> ]
         | st = str_item -> st
         | -> <:str_item<>> ] ]
     ;
     sig_item_quot:
       [ [ "#"; n = a_LIDENT; dp = opt_expr -> <:sig_item< # $n$ $dp$ >>
-        | sg1 = sig_item; semi; sg2 = SELF -> <:sig_item< $sg1$; $sg2$ >>
+        | sg1 = sig_item; semi; sg2 = SELF ->
+            match sg2 with
+            [ <:sig_item<>> -> sg1
+            | _ -> <:sig_item< $sg1$; $sg2$ >> ]
         | sg = sig_item -> sg
         | -> <:sig_item<>> ] ]
     ;
@@ -1832,12 +1887,17 @@ New syntax:\
     ;
     class_str_item_quot:
       [ [ x1 = class_str_item; semi; x2 = SELF ->
-          <:class_str_item< $x1$; $x2$ >>
+          match x2 with
+          [ <:class_str_item<>> -> x1
+          | _ -> <:class_str_item< $x1$; $x2$ >> ]
         | x = class_str_item -> x
         | -> <:class_str_item<>> ] ]
     ;
     class_sig_item_quot:
-      [ [ x1 = class_sig_item; semi; x2 = SELF -> <:class_sig_item< $x1$; $x2$ >>
+      [ [ x1 = class_sig_item; semi; x2 = SELF ->
+          match x2 with
+          [ <:class_sig_item<>> -> x1
+          | _ -> <:class_sig_item< $x1$; $x2$ >> ]
         | x = class_sig_item -> x
         | -> <:class_sig_item<>> ] ]
     ;

diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml
index 97747d448e139d8ebf60909af28a18c6f8ffdfc8..2bdab6bf9e6f54e3ead36260785ff1d8e1670f5d 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                        (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 1998-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml
index 07d2a01eb9e4570eb914e5db312231decd20e539..2e32bcd837ffa84b18704a7ddd786598b222f0a5 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml
+++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                             (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml
index 76e67f4123f4a11749efb31ac04258945eb6b0ab..3cf80b560df5ef934e76a8cb3d120f2181cd91b2 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml
+++ b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                             (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml
index fb225a583d7550f418fce316497b831a3a311efb..81680c6b46796941be441fa078cacb73b1b1381b 100644 (file)
--- a/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml
+++ b/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml
@@ -1,15 +1,15 @@
 open Camlp4;                                        (* -*- camlp4r -*- *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Printers/Camlp4AstDumper.ml b/camlp4/Camlp4Printers/Camlp4AstDumper.ml
index f89fed40f2fb5726f646e7dba5fa68a918393be5..b9adf908568fb7b4e7ccf2b840fcd8dd6f7fed39 100644 (file)
--- a/camlp4/Camlp4Printers/Camlp4AstDumper.ml
+++ b/camlp4/Camlp4Printers/Camlp4AstDumper.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml b/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml
index eb6b9a24dd425a6494f2c8aef0af2ef933b64cb2..4b2787efcb4f76c47ac72f986f5a5af33a9a8ffb 100644 (file)
--- a/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml
+++ b/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Printers/Camlp4NullDumper.ml b/camlp4/Camlp4Printers/Camlp4NullDumper.ml
index 0e02b66dfde635c2f8d6640d8f15c41b01cc6e58..77105dc7d40aa37a48aa6d747cb56e2574ae35ee 100644 (file)
--- a/camlp4/Camlp4Printers/Camlp4NullDumper.ml
+++ b/camlp4/Camlp4Printers/Camlp4NullDumper.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml b/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml
index 174e5ad13c5a71dc065f0d29d9a92a8ed523acd9..872be92587a6c9faaf323ab4fa80f58a99d302c3 100644 (file)
--- a/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml
+++ b/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml b/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml
index 487b8627bff12b187c7a4faf186d126510034dcb..63fd2a1c7b6a266cb6b7d29e4efa39886acc7b25 100644 (file)
--- a/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml
+++ b/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml b/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml
index bd5af1f50dc9d9ae4053a1bc862855433ba10636..4f8bf71d720fb27615a42af13143d09f25a95136 100644 (file)
--- a/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml
+++ b/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/Camlp4Top/Rprint.ml b/camlp4/Camlp4Top/Rprint.ml
index ce772d1db717a6986c934846e7f6b59de8fc9da2..d913efcca011a5ae7d5e41eaa6d1c542bc15ed75 100644 (file)
--- a/camlp4/Camlp4Top/Rprint.ml
+++ b/camlp4/Camlp4Top/Rprint.ml
@@ -1,15 +1,15 @@
 (* camlp4r *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -246,10 +246,14 @@ and print_simple_out_type ppf =
       fprintf ppf "@[<1>(%a)@]" print_out_type ty ]
   in
   print_tkind ppf
-and print_out_constr ppf (name, tyl) =
-  match tyl with
-  [ [] -> fprintf ppf "%s" name
-  | _ ->
+and print_out_constr ppf (name, tyl, ret) =
+  match (tyl,ret) with
+  [ ([], None) -> fprintf ppf "%s" name
+  | ([], Some r) -> fprintf ppf "@[<2>%s:@ %a@]" name print_out_type r
+  | (_,Some r) ->
+      fprintf ppf "@[<2>%s:@ %a -> %a@]" name
+        (print_typlist print_out_type " and") tyl print_out_type r
+  | (_,None) ->
       fprintf ppf "@[<2>%s of@ %a@]" name
         (print_typlist print_out_type " and") tyl ]
 and print_out_label ppf (name, mut, arg) =
@@ -392,7 +396,7 @@ and print_out_sig_item ppf =
         (if vir_flag then " virtual" else "") print_out_class_params params
         name Toploop.print_out_class_type.val clt
   | Osig_exception id tyl ->
-      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
+      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None)
   | Osig_modtype name Omty_abstract ->
       fprintf ppf "@[<2>module type %s@]" name
   | Osig_modtype name mty ->

diff --git a/camlp4/Camlp4Top/Top.ml b/camlp4/Camlp4Top/Top.ml
index dcd3aa460714b14cc12e260d2dc9295e23d81055..0e07eb21e6f726d2562d584bf3bd2d4cba900a05 100644 (file)
--- a/camlp4/Camlp4Top/Top.ml
+++ b/camlp4/Camlp4Top/Top.ml
@@ -1,15 +1,15 @@
 (* camlp4r q_MLast.cmo *)
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -60,45 +60,31 @@ value initialization = lazy begin
     else ()
 end;
 
-value lookup x xs = try Some (List.assq x xs) with [ Not_found -> None ];
-
-value wrap parse_fun =
-  let token_streams = ref [] in
-  let cleanup lb =
-    try token_streams.val := List.remove_assq lb token_streams.val
-    with [ Not_found -> () ]
-  in
-  fun lb ->
-    let () = Lazy.force initialization in
-    let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in
-    let token_stream =
-      match lookup lb token_streams.val with
-      [ None ->
-        let not_filtered_token_stream = Lexer.from_lexbuf lb in
-        let token_stream = Gram.filter (not_filtered not_filtered_token_stream) in
-        do { token_streams.val := [ (lb,token_stream) :: token_streams.val ]; token_stream }
-      | Some token_stream -> token_stream ]
-    in try
-      match token_stream with parser
-      [ [: `(EOI, _) :] -> raise End_of_file
-      | [: :] -> parse_fun token_stream ]
-    with
-    [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break))
-        as x -> (cleanup lb; raise x)
-    | x ->
-        let x =
-          match x with
-          [ Loc.Exc_located loc x -> do {
+value wrap parse_fun lb =
+  let () = Lazy.force initialization in
+  let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in
+  let not_filtered_token_stream = Lexer.from_lexbuf lb in
+  let token_stream = Gram.filter (not_filtered not_filtered_token_stream) in
+  try
+    match token_stream with parser
+    [ [: `(EOI, _) :] -> raise End_of_file
+    | [: :] -> parse_fun token_stream ]
+  with
+  [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break))
+        as x -> raise x
+  | x ->
+      let x =
+        match x with
+        [ Loc.Exc_located loc x -> do {
             Toploop.print_location Format.err_formatter
               (Loc.to_ocaml_location loc);
             x }
-          | x -> x ]
-        in
-        do {
-          cleanup lb;
-          Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x;
-          raise Exit
-        } ];
+        | x -> x ]
+      in
+      do {
+        Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x;
+        raise Exit
+      } ];
 
 value toplevel_phrase token_stream =
   match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with

diff --git a/camlp4/Camlp4_config.ml b/camlp4/Camlp4_config.ml
index 745930b79a0fe402690d7d85e038d87deefae1fb..a055e6ca470746775d0096bea63e77ffc189277b 100644 (file)
--- a/camlp4/Camlp4_config.ml
+++ b/camlp4/Camlp4_config.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 
@@ -32,8 +32,8 @@ let verbose            = ref false;;
 let antiquotations     = ref false;;
 let quotations         = ref true;;
 let inter_phrases      = ref None;;
-let camlp4_ast_impl_magic_number = "Camlp42006M001";;
-let camlp4_ast_intf_magic_number = "Camlp42006N001";;
+let camlp4_ast_impl_magic_number = "Camlp42006M002";;
+let camlp4_ast_intf_magic_number = "Camlp42006N002";;
 let ocaml_ast_intf_magic_number = Camlp4_import.Config.ast_intf_magic_number;;
 let ocaml_ast_impl_magic_number = Camlp4_import.Config.ast_impl_magic_number;;
 let current_input_file = ref "";;

diff --git a/camlp4/Camlp4_config.mli b/camlp4/Camlp4_config.mli
index 175920846330e065f72b1f59c8978328b46262d7..cbc1632233c1dcd92aaf8b786e4f6fcbfaa4219c 100644 (file)
--- a/camlp4/Camlp4_config.mli
+++ b/camlp4/Camlp4_config.mli
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/boot/.cvsignore b/camlp4/boot/.cvsignore
deleted file mode 100644 (file)
index 85599a4..0000000
--- a/camlp4/boot/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-*.cm[oia]
-camlp4
-camlp4o
-camlp4r
-SAVED

diff --git a/camlp4/boot/.ignore b/camlp4/boot/.ignore
new file mode 100644 (file)
index 0000000..03db148
--- /dev/null
+++ b/camlp4/boot/.ignore
@@ -0,0 +1,4 @@
+camlp4
+camlp4o
+camlp4r
+SAVED

diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 2dc658138cb9df531b9682cb82de622e535d1171..3967ba21b5488f0cf6e32a371551b6a98fa67a3f 100644 (file)
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -2,15 +2,15 @@ module Debug :
   sig
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -28,15 +28,15 @@ module Debug :
   struct
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -110,15 +110,15 @@ module Options :
   sig
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -142,15 +142,15 @@ module Options :
   struct
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -357,15 +357,15 @@ module Sig =
     (* camlp4r *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -671,145 +671,83 @@ module Sig =
         class map :
           object ('self_type)
             method string : string -> string
-              
             method list :
               'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list
-              
             method meta_bool : meta_bool -> meta_bool
-              
             method meta_option :
               'a 'b.
                 ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option
-              
             method meta_list :
               'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list
-              
             method loc : loc -> loc
-              
             method expr : expr -> expr
-              
             method patt : patt -> patt
-              
             method ctyp : ctyp -> ctyp
-              
             method str_item : str_item -> str_item
-              
             method sig_item : sig_item -> sig_item
-              
             method module_expr : module_expr -> module_expr
-              
             method module_type : module_type -> module_type
-              
             method class_expr : class_expr -> class_expr
-              
             method class_type : class_type -> class_type
-              
             method class_sig_item : class_sig_item -> class_sig_item
-              
             method class_str_item : class_str_item -> class_str_item
-              
             method with_constr : with_constr -> with_constr
-              
             method binding : binding -> binding
-              
             method rec_binding : rec_binding -> rec_binding
-              
             method module_binding : module_binding -> module_binding
-              
             method match_case : match_case -> match_case
-              
             method ident : ident -> ident
-              
             method override_flag : override_flag -> override_flag
-              
             method mutable_flag : mutable_flag -> mutable_flag
-              
             method private_flag : private_flag -> private_flag
-              
             method virtual_flag : virtual_flag -> virtual_flag
-              
             method direction_flag : direction_flag -> direction_flag
-              
             method rec_flag : rec_flag -> rec_flag
-              
             method row_var_flag : row_var_flag -> row_var_flag
-              
             method unknown : 'a. 'a -> 'a
-              
           end
           
         (** Fold style traversal *)
         class fold :
           object ('self_type)
             method string : string -> 'self_type
-              
             method list :
               'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type
-              
             method meta_bool : meta_bool -> 'self_type
-              
             method meta_option :
               'a.
                 ('self_type -> 'a -> 'self_type) ->
                   'a meta_option -> 'self_type
-              
             method meta_list :
               'a.
                 ('self_type -> 'a -> 'self_type) ->
                   'a meta_list -> 'self_type
-              
             method loc : loc -> 'self_type
-              
             method expr : expr -> 'self_type
-              
             method patt : patt -> 'self_type
-              
             method ctyp : ctyp -> 'self_type
-              
             method str_item : str_item -> 'self_type
-              
             method sig_item : sig_item -> 'self_type
-              
             method module_expr : module_expr -> 'self_type
-              
             method module_type : module_type -> 'self_type
-              
             method class_expr : class_expr -> 'self_type
-              
             method class_type : class_type -> 'self_type
-              
             method class_sig_item : class_sig_item -> 'self_type
-              
             method class_str_item : class_str_item -> 'self_type
-              
             method with_constr : with_constr -> 'self_type
-              
             method binding : binding -> 'self_type
-              
             method rec_binding : rec_binding -> 'self_type
-              
             method module_binding : module_binding -> 'self_type
-              
             method match_case : match_case -> 'self_type
-              
             method ident : ident -> 'self_type
-              
             method rec_flag : rec_flag -> 'self_type
-              
             method direction_flag : direction_flag -> 'self_type
-              
             method mutable_flag : mutable_flag -> 'self_type
-              
             method private_flag : private_flag -> 'self_type
-              
             method virtual_flag : virtual_flag -> 'self_type
-              
             method row_var_flag : row_var_flag -> 'self_type
-              
             method override_flag : override_flag -> 'self_type
-              
             method unknown : 'a. 'a -> 'self_type
-              
           end
           
       end
@@ -850,6 +788,19 @@ module Sig =
         (** The inner module for locations *)
         module Loc : Loc
           
+        (****************************************************************************)
+        (*                                                                          *)
+        (*                                   OCaml                                  *)
+        (*                                                                          *)
+        (*                            INRIA Rocquencourt                            *)
+        (*                                                                          *)
+        (*  Copyright  2007   Institut National de Recherche  en  Informatique et   *)
+        (*  en Automatique.  All rights reserved.  This file is distributed under   *)
+        (*  the terms of the GNU Library General Public License, with the special   *)
+        (*  exception on linking described in LICENSE at the top of the OCaml       *)
+        (*  source tree.                                                            *)
+        (*                                                                          *)
+        (****************************************************************************)
         type loc =
           Loc.
           t
@@ -918,12 +869,19 @@ module Sig =
           TyPol of loc * ctyp * ctyp
           | (* ! t . t *)
           (* ! 'a . list 'a -> 'a *)
+          TyTypePol of loc * ctyp * ctyp
+          | (* type t . t *)
+          (* type a . list a -> a *)
           TyQuo of loc * string
           | (* 's *)
           TyQuP of loc * string
           | (* +'s *)
           TyQuM of loc * string
           | (* -'s *)
+          TyAnP of loc
+          | (* +_ *)
+          TyAnM of loc
+          | (* -_ *)
           TyVrn of loc * string
           | (* `s *)
           TyRec of loc * ctyp
@@ -1023,7 +981,9 @@ module Sig =
           PaVrn of loc * string
           | (* `s *)
           PaLaz of loc * patt
-          and (* lazy p *)
+          | (* lazy p *)
+          PaMod of loc * string
+          and (* (module M) *)
           expr =
           | ExNil of loc
           | ExId of loc * ident
@@ -1537,144 +1497,82 @@ module Sig =
         class map :
           object ('self_type)
             method string : string -> string
-              
             method list :
               'a 'b. ('self_type -> 'a -> 'b) -> 'a list -> 'b list
-              
             method meta_bool : meta_bool -> meta_bool
-              
             method meta_option :
               'a 'b.
                 ('self_type -> 'a -> 'b) -> 'a meta_option -> 'b meta_option
-              
             method meta_list :
               'a 'b. ('self_type -> 'a -> 'b) -> 'a meta_list -> 'b meta_list
-              
             method loc : loc -> loc
-              
             method expr : expr -> expr
-              
             method patt : patt -> patt
-              
             method ctyp : ctyp -> ctyp
-              
             method str_item : str_item -> str_item
-              
             method sig_item : sig_item -> sig_item
-              
             method module_expr : module_expr -> module_expr
-              
             method module_type : module_type -> module_type
-              
             method class_expr : class_expr -> class_expr
-              
             method class_type : class_type -> class_type
-              
             method class_sig_item : class_sig_item -> class_sig_item
-              
             method class_str_item : class_str_item -> class_str_item
-              
             method with_constr : with_constr -> with_constr
-              
             method binding : binding -> binding
-              
             method rec_binding : rec_binding -> rec_binding
-              
             method module_binding : module_binding -> module_binding
-              
             method match_case : match_case -> match_case
-              
             method ident : ident -> ident
-              
             method mutable_flag : mutable_flag -> mutable_flag
-              
             method private_flag : private_flag -> private_flag
-              
             method virtual_flag : virtual_flag -> virtual_flag
-              
             method direction_flag : direction_flag -> direction_flag
-              
             method rec_flag : rec_flag -> rec_flag
-              
             method row_var_flag : row_var_flag -> row_var_flag
-              
             method override_flag : override_flag -> override_flag
-              
             method unknown : 'a. 'a -> 'a
-              
           end
           
         class fold :
           object ('self_type)
             method string : string -> 'self_type
-              
             method list :
               'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type
-              
             method meta_bool : meta_bool -> 'self_type
-              
             method meta_option :
               'a.
                 ('self_type -> 'a -> 'self_type) ->
                   'a meta_option -> 'self_type
-              
             method meta_list :
               'a.
                 ('self_type -> 'a -> 'self_type) ->
                   'a meta_list -> 'self_type
-              
             method loc : loc -> 'self_type
-              
             method expr : expr -> 'self_type
-              
             method patt : patt -> 'self_type
-              
             method ctyp : ctyp -> 'self_type
-              
             method str_item : str_item -> 'self_type
-              
             method sig_item : sig_item -> 'self_type
-              
             method module_expr : module_expr -> 'self_type
-              
             method module_type : module_type -> 'self_type
-              
             method class_expr : class_expr -> 'self_type
-              
             method class_type : class_type -> 'self_type
-              
             method class_sig_item : class_sig_item -> 'self_type
-              
             method class_str_item : class_str_item -> 'self_type
-              
             method with_constr : with_constr -> 'self_type
-              
             method binding : binding -> 'self_type
-              
             method rec_binding : rec_binding -> 'self_type
-              
             method module_binding : module_binding -> 'self_type
-              
             method match_case : match_case -> 'self_type
-              
             method ident : ident -> 'self_type
-              
             method rec_flag : rec_flag -> 'self_type
-              
             method direction_flag : direction_flag -> 'self_type
-              
             method mutable_flag : mutable_flag -> 'self_type
-              
             method private_flag : private_flag -> 'self_type
-              
             method virtual_flag : virtual_flag -> 'self_type
-              
             method row_var_flag : row_var_flag -> 'self_type
-              
             method override_flag : override_flag -> 'self_type
-              
             method unknown : 'a. 'a -> 'self_type
-              
           end
           
         val map_expr : (expr -> expr) -> map
@@ -1878,9 +1776,12 @@ module Sig =
           | TyObj of loc * ctyp * row_var_flag
           | TyOlb of loc * string * ctyp
           | TyPol of loc * ctyp * ctyp
+          | TyTypePol of loc * ctyp * ctyp
           | TyQuo of loc * string
           | TyQuP of loc * string
           | TyQuM of loc * string
+          | TyAnP of loc
+          | TyAnM of loc
           | TyVrn of loc * string
           | TyRec of loc * ctyp
           | TyCol of loc * ctyp * ctyp
@@ -1931,6 +1832,7 @@ module Sig =
           | PaTyp of loc * ident
           | PaVrn of loc * string
           | PaLaz of loc * patt
+          | PaMod of loc * string
           and expr =
           | ExNil of loc
           | ExId of loc * ident
@@ -3880,6 +3782,15 @@ module Struct =
                     pos_bol = pos.pos_cnum - chars;
                   }
               
+            let cvt_int_literal s = - (int_of_string ("-" ^ s))
+              
+            let cvt_int32_literal s = Int32.neg (Int32.of_string ("-" ^ s))
+              
+            let cvt_int64_literal s = Int64.neg (Int64.of_string ("-" ^ s))
+              
+            let cvt_nativeint_literal s =
+              Nativeint.neg (Nativeint.of_string ("-" ^ s))
+              
             let err error loc =
               raise (Loc.Exc_located (loc, (Error.E error)))
               
@@ -6473,7 +6384,7 @@ module Struct =
                     Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos
                       lexbuf.Lexing.lex_curr_pos
                   in
-                    (try INT ((int_of_string i), i)
+                    (try INT ((cvt_int_literal i), i)
                      with
                      | Failure _ ->
                          err (Literal_overflow "int") (Loc.of_lexbuf lexbuf))
@@ -6492,7 +6403,7 @@ module Struct =
                     Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos
                       (lexbuf.Lexing.lex_curr_pos + (-1))
                   in
-                    (try INT32 ((Int32.of_string i), i)
+                    (try INT32 ((cvt_int32_literal i), i)
                      with
                      | Failure _ ->
                          err (Literal_overflow "int32")
@@ -6502,7 +6413,7 @@ module Struct =
                     Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos
                       (lexbuf.Lexing.lex_curr_pos + (-1))
                   in
-                    (try INT64 ((Int64.of_string i), i)
+                    (try INT64 ((cvt_int64_literal i), i)
                      with
                      | Failure _ ->
                          err (Literal_overflow "int64")
@@ -6512,7 +6423,7 @@ module Struct =
                     Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos
                       (lexbuf.Lexing.lex_curr_pos + (-1))
                   in
-                    (try NATIVEINT ((Nativeint.of_string i), i)
+                    (try NATIVEINT ((cvt_nativeint_literal i), i)
                      with
                      | Failure _ ->
                          err (Literal_overflow "nativeint")
@@ -7030,6 +6941,7 @@ module Struct =
               | Ast.PaLab (_, _, p) -> is_irrefut_patt p
               | Ast.PaLaz (_, p) -> is_irrefut_patt p
               | Ast.PaId (_, _) -> false
+              | Ast.PaMod (_, _) -> true
               | Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) |
                   Ast.PaFlo (_, _) | Ast.PaNativeInt (_, _) |
                   Ast.PaInt64 (_, _) | Ast.PaInt32 (_, _) | Ast.PaInt (_, _)
@@ -8138,6 +8050,20 @@ module Struct =
                                          (Ast.IdUid (_loc, "TyVrn")))))),
                                    (meta_loc _loc x0))),
                                 (meta_string _loc x1))
+                          | Ast.TyAnM x0 ->
+                              Ast.ExApp (_loc,
+                                (Ast.ExId (_loc,
+                                   (Ast.IdAcc (_loc,
+                                      (Ast.IdUid (_loc, "Ast")),
+                                      (Ast.IdUid (_loc, "TyAnM")))))),
+                                (meta_loc _loc x0))
+                          | Ast.TyAnP x0 ->
+                              Ast.ExApp (_loc,
+                                (Ast.ExId (_loc,
+                                   (Ast.IdAcc (_loc,
+                                      (Ast.IdUid (_loc, "Ast")),
+                                      (Ast.IdUid (_loc, "TyAnP")))))),
+                                (meta_loc _loc x0))
                           | Ast.TyQuM (x0, x1) ->
                               Ast.ExApp (_loc,
                                 (Ast.ExApp (_loc,
@@ -8165,6 +8091,17 @@ module Struct =
                                          (Ast.IdUid (_loc, "TyQuo")))))),
                                    (meta_loc _loc x0))),
                                 (meta_string _loc x1))
+                          | Ast.TyTypePol (x0, x1, x2) ->
+                              Ast.ExApp (_loc,
+                                (Ast.ExApp (_loc,
+                                   (Ast.ExApp (_loc,
+                                      (Ast.ExId (_loc,
+                                         (Ast.IdAcc (_loc,
+                                            (Ast.IdUid (_loc, "Ast")),
+                                            (Ast.IdUid (_loc, "TyTypePol")))))),
+                                      (meta_loc _loc x0))),
+                                   (meta_ctyp _loc x1))),
+                                (meta_ctyp _loc x2))
                           | Ast.TyPol (x0, x1, x2) ->
                               Ast.ExApp (_loc,
                                 (Ast.ExApp (_loc,
@@ -9093,6 +9030,15 @@ module Struct =
                                    (Ast.IdUid (_loc, "OvOverride")))))
                         and meta_patt _loc =
                           function
+                          | Ast.PaMod (x0, x1) ->
+                              Ast.ExApp (_loc,
+                                (Ast.ExApp (_loc,
+                                   (Ast.ExId (_loc,
+                                      (Ast.IdAcc (_loc,
+                                         (Ast.IdUid (_loc, "Ast")),
+                                         (Ast.IdUid (_loc, "PaMod")))))),
+                                   (meta_loc _loc x0))),
+                                (meta_string _loc x1))
                           | Ast.PaLaz (x0, x1) ->
                               Ast.ExApp (_loc,
                                 (Ast.ExApp (_loc,
@@ -10433,6 +10379,20 @@ module Struct =
                                          (Ast.IdUid (_loc, "TyVrn")))))),
                                    (meta_loc _loc x0))),
                                 (meta_string _loc x1))
+                          | Ast.TyAnM x0 ->
+                              Ast.PaApp (_loc,
+                                (Ast.PaId (_loc,
+                                   (Ast.IdAcc (_loc,
+                                      (Ast.IdUid (_loc, "Ast")),
+                                      (Ast.IdUid (_loc, "TyAnM")))))),
+                                (meta_loc _loc x0))
+                          | Ast.TyAnP x0 ->
+                              Ast.PaApp (_loc,
+                                (Ast.PaId (_loc,
+                                   (Ast.IdAcc (_loc,
+                                      (Ast.IdUid (_loc, "Ast")),
+                                      (Ast.IdUid (_loc, "TyAnP")))))),
+                                (meta_loc _loc x0))
                           | Ast.TyQuM (x0, x1) ->
                               Ast.PaApp (_loc,
                                 (Ast.PaApp (_loc,
@@ -10460,6 +10420,17 @@ module Struct =
                                          (Ast.IdUid (_loc, "TyQuo")))))),
                                    (meta_loc _loc x0))),
                                 (meta_string _loc x1))
+                          | Ast.TyTypePol (x0, x1, x2) ->
+                              Ast.PaApp (_loc,
+                                (Ast.PaApp (_loc,
+                                   (Ast.PaApp (_loc,
+                                      (Ast.PaId (_loc,
+                                         (Ast.IdAcc (_loc,
+                                            (Ast.IdUid (_loc, "Ast")),
+                                            (Ast.IdUid (_loc, "TyTypePol")))))),
+                                      (meta_loc _loc x0))),
+                                   (meta_ctyp _loc x1))),
+                                (meta_ctyp _loc x2))
                           | Ast.TyPol (x0, x1, x2) ->
                               Ast.PaApp (_loc,
                                 (Ast.PaApp (_loc,
@@ -11388,6 +11359,15 @@ module Struct =
                                    (Ast.IdUid (_loc, "OvOverride")))))
                         and meta_patt _loc =
                           function
+                          | Ast.PaMod (x0, x1) ->
+                              Ast.PaApp (_loc,
+                                (Ast.PaApp (_loc,
+                                   (Ast.PaId (_loc,
+                                      (Ast.IdAcc (_loc,
+                                         (Ast.IdUid (_loc, "Ast")),
+                                         (Ast.IdUid (_loc, "PaMod")))))),
+                                   (meta_loc _loc x0))),
+                                (meta_string _loc x1))
                           | Ast.PaLaz (x0, x1) ->
                               Ast.PaApp (_loc,
                                 (Ast.PaApp (_loc,
@@ -12096,7 +12076,6 @@ module Struct =
             class map =
               object ((o : 'self_type))
                 method string : string -> string = o#unknown
-                  
                 method list :
                   'a 'a_out.
                     ('self_type -> 'a -> 'a_out) -> 'a list -> 'a_out list =
@@ -12106,7 +12085,6 @@ module Struct =
                     | _x :: _x_i1 ->
                         let _x = _f_a o _x in
                         let _x_i1 = o#list _f_a _x_i1 in _x :: _x_i1
-                  
                 method with_constr : with_constr -> with_constr =
                   function
                   | WcNil _x -> let _x = o#loc _x in WcNil _x
@@ -12134,13 +12112,11 @@ module Struct =
                   | WcAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in WcAnt (_x, _x_i1)
-                  
                 method virtual_flag : virtual_flag -> virtual_flag =
                   function
                   | ViVirtual -> ViVirtual
                   | ViNil -> ViNil
                   | ViAnt _x -> let _x = o#string _x in ViAnt _x
-                  
                 method str_item : str_item -> str_item =
                   function
                   | StNil _x -> let _x = o#loc _x in StNil _x
@@ -12203,7 +12179,6 @@ module Struct =
                   | StAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in StAnt (_x, _x_i1)
-                  
                 method sig_item : sig_item -> sig_item =
                   function
                   | SgNil _x -> let _x = o#loc _x in SgNil _x
@@ -12261,19 +12236,16 @@ module Struct =
                   | SgAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in SgAnt (_x, _x_i1)
-                  
                 method row_var_flag : row_var_flag -> row_var_flag =
                   function
                   | RvRowVar -> RvRowVar
                   | RvNil -> RvNil
                   | RvAnt _x -> let _x = o#string _x in RvAnt _x
-                  
                 method rec_flag : rec_flag -> rec_flag =
                   function
                   | ReRecursive -> ReRecursive
                   | ReNil -> ReNil
                   | ReAnt _x -> let _x = o#string _x in ReAnt _x
-                  
                 method rec_binding : rec_binding -> rec_binding =
                   function
                   | RbNil _x -> let _x = o#loc _x in RbNil _x
@@ -12289,13 +12261,11 @@ module Struct =
                   | RbAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in RbAnt (_x, _x_i1)
-                  
                 method private_flag : private_flag -> private_flag =
                   function
                   | PrPrivate -> PrPrivate
                   | PrNil -> PrNil
                   | PrAnt _x -> let _x = o#string _x in PrAnt _x
-                  
                 method patt : patt -> patt =
                   function
                   | PaNil _x -> let _x = o#loc _x in PaNil _x
@@ -12391,19 +12361,19 @@ module Struct =
                   | PaLaz (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1)
-                  
+                  | PaMod (_x, _x_i1) ->
+                      let _x = o#loc _x in
+                      let _x_i1 = o#string _x_i1 in PaMod (_x, _x_i1)
                 method override_flag : override_flag -> override_flag =
                   function
                   | OvOverride -> OvOverride
                   | OvNil -> OvNil
                   | OvAnt _x -> let _x = o#string _x in OvAnt _x
-                  
                 method mutable_flag : mutable_flag -> mutable_flag =
                   function
                   | MuMutable -> MuMutable
                   | MuNil -> MuNil
                   | MuAnt _x -> let _x = o#string _x in MuAnt _x
-                  
                 method module_type : module_type -> module_type =
                   function
                   | MtNil _x -> let _x = o#loc _x in MtNil _x
@@ -12433,7 +12403,6 @@ module Struct =
                   | MtAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in MtAnt (_x, _x_i1)
-                  
                 method module_expr : module_expr -> module_expr =
                   function
                   | MeNil _x -> let _x = o#loc _x in MeNil _x
@@ -12465,7 +12434,6 @@ module Struct =
                   | MeAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in MeAnt (_x, _x_i1)
-                  
                 method module_binding : module_binding -> module_binding =
                   function
                   | MbNil _x -> let _x = o#loc _x in MbNil _x
@@ -12488,7 +12456,6 @@ module Struct =
                   | MbAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in MbAnt (_x, _x_i1)
-                  
                 method meta_option :
                   'a 'a_out.
                     ('self_type -> 'a -> 'a_out) ->
@@ -12498,7 +12465,6 @@ module Struct =
                     | ONone -> ONone
                     | OSome _x -> let _x = _f_a o _x in OSome _x
                     | OAnt _x -> let _x = o#string _x in OAnt _x
-                  
                 method meta_list :
                   'a 'a_out.
                     ('self_type -> 'a -> 'a_out) ->
@@ -12511,13 +12477,11 @@ module Struct =
                         let _x_i1 = o#meta_list _f_a _x_i1
                         in LCons (_x, _x_i1)
                     | LAnt _x -> let _x = o#string _x in LAnt _x
-                  
                 method meta_bool : meta_bool -> meta_bool =
                   function
                   | BTrue -> BTrue
                   | BFalse -> BFalse
                   | BAnt _x -> let _x = o#string _x in BAnt _x
-                  
                 method match_case : match_case -> match_case =
                   function
                   | McNil _x -> let _x = o#loc _x in McNil _x
@@ -12535,9 +12499,7 @@ module Struct =
                   | McAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in McAnt (_x, _x_i1)
-                  
                 method loc : loc -> loc = o#unknown
-                  
                 method ident : ident -> ident =
                   function
                   | IdAcc (_x, _x_i1, _x_i2) ->
@@ -12557,7 +12519,6 @@ module Struct =
                   | IdAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in IdAnt (_x, _x_i1)
-                  
                 method expr : expr -> expr =
                   function
                   | ExNil _x -> let _x = o#loc _x in ExNil _x
@@ -12726,13 +12687,11 @@ module Struct =
                   | ExPkg (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#module_expr _x_i1 in ExPkg (_x, _x_i1)
-                  
                 method direction_flag : direction_flag -> direction_flag =
                   function
                   | DiTo -> DiTo
                   | DiDownto -> DiDownto
                   | DiAnt _x -> let _x = o#string _x in DiAnt _x
-                  
                 method ctyp : ctyp -> ctyp =
                   function
                   | TyNil _x -> let _x = o#loc _x in TyNil _x
@@ -12788,6 +12747,11 @@ module Struct =
                       let _x = o#loc _x in
                       let _x_i1 = o#ctyp _x_i1 in
                       let _x_i2 = o#ctyp _x_i2 in TyPol (_x, _x_i1, _x_i2)
+                  | TyTypePol (_x, _x_i1, _x_i2) ->
+                      let _x = o#loc _x in
+                      let _x_i1 = o#ctyp _x_i1 in
+                      let _x_i2 = o#ctyp _x_i2
+                      in TyTypePol (_x, _x_i1, _x_i2)
                   | TyQuo (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in TyQuo (_x, _x_i1)
@@ -12797,6 +12761,8 @@ module Struct =
                   | TyQuM (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in TyQuM (_x, _x_i1)
+                  | TyAnP _x -> let _x = o#loc _x in TyAnP _x
+                  | TyAnM _x -> let _x = o#loc _x in TyAnM _x
                   | TyVrn (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in TyVrn (_x, _x_i1)
@@ -12871,7 +12837,6 @@ module Struct =
                   | TyAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in TyAnt (_x, _x_i1)
-                  
                 method class_type : class_type -> class_type =
                   function
                   | CtNil _x -> let _x = o#loc _x in CtNil _x
@@ -12909,7 +12874,6 @@ module Struct =
                   | CtAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in CtAnt (_x, _x_i1)
-                  
                 method class_str_item : class_str_item -> class_str_item =
                   function
                   | CrNil _x -> let _x = o#loc _x in CrNil _x
@@ -12961,7 +12925,6 @@ module Struct =
                   | CrAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in CrAnt (_x, _x_i1)
-                  
                 method class_sig_item : class_sig_item -> class_sig_item =
                   function
                   | CgNil _x -> let _x = o#loc _x in CgNil _x
@@ -12999,7 +12962,6 @@ module Struct =
                   | CgAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in CgAnt (_x, _x_i1)
-                  
                 method class_expr : class_expr -> class_expr =
                   function
                   | CeNil _x -> let _x = o#loc _x in CeNil _x
@@ -13047,7 +13009,6 @@ module Struct =
                   | CeAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in CeAnt (_x, _x_i1)
-                  
                 method binding : binding -> binding =
                   function
                   | BiNil _x -> let _x = o#loc _x in BiNil _x
@@ -13062,15 +13023,12 @@ module Struct =
                   | BiAnt (_x, _x_i1) ->
                       let _x = o#loc _x in
                       let _x_i1 = o#string _x_i1 in BiAnt (_x, _x_i1)
-                  
                 method unknown : 'a. 'a -> 'a = fun x -> x
-                  
               end
               
             class fold =
               object ((o : 'self_type))
                 method string : string -> 'self_type = o#unknown
-                  
                 method list :
                   'a.
                     ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type =
@@ -13079,7 +13037,6 @@ module Struct =
                     | [] -> o
                     | _x :: _x_i1 ->
                         let o = _f_a o _x in let o = o#list _f_a _x_i1 in o
-                  
                 method with_constr : with_constr -> 'self_type =
                   function
                   | WcNil _x -> let o = o#loc _x in o
@@ -13101,13 +13058,11 @@ module Struct =
                       let o = o#with_constr _x_i2 in o
                   | WcAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method virtual_flag : virtual_flag -> 'self_type =
                   function
                   | ViVirtual -> o
                   | ViNil -> o
                   | ViAnt _x -> let o = o#string _x in o
-                  
                 method str_item : str_item -> 'self_type =
                   function
                   | StNil _x -> let o = o#loc _x in o
@@ -13155,7 +13110,6 @@ module Struct =
                       let o = o#binding _x_i2 in o
                   | StAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method sig_item : sig_item -> 'self_type =
                   function
                   | SgNil _x -> let o = o#loc _x in o
@@ -13198,19 +13152,16 @@ module Struct =
                       let o = o#string _x_i1 in let o = o#ctyp _x_i2 in o
                   | SgAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method row_var_flag : row_var_flag -> 'self_type =
                   function
                   | RvRowVar -> o
                   | RvNil -> o
                   | RvAnt _x -> let o = o#string _x in o
-                  
                 method rec_flag : rec_flag -> 'self_type =
                   function
                   | ReRecursive -> o
                   | ReNil -> o
                   | ReAnt _x -> let o = o#string _x in o
-                  
                 method rec_binding : rec_binding -> 'self_type =
                   function
                   | RbNil _x -> let o = o#loc _x in o
@@ -13223,13 +13174,11 @@ module Struct =
                       let o = o#ident _x_i1 in let o = o#expr _x_i2 in o
                   | RbAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method private_flag : private_flag -> 'self_type =
                   function
                   | PrPrivate -> o
                   | PrNil -> o
                   | PrAnt _x -> let o = o#string _x in o
-                  
                 method patt : patt -> 'self_type =
                   function
                   | PaNil _x -> let o = o#loc _x in o
@@ -13298,19 +13247,18 @@ module Struct =
                       let o = o#loc _x in let o = o#string _x_i1 in o
                   | PaLaz (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#patt _x_i1 in o
-                  
+                  | PaMod (_x, _x_i1) ->
+                      let o = o#loc _x in let o = o#string _x_i1 in o
                 method override_flag : override_flag -> 'self_type =
                   function
                   | OvOverride -> o
                   | OvNil -> o
                   | OvAnt _x -> let o = o#string _x in o
-                  
                 method mutable_flag : mutable_flag -> 'self_type =
                   function
                   | MuMutable -> o
                   | MuNil -> o
                   | MuAnt _x -> let o = o#string _x in o
-                  
                 method module_type : module_type -> 'self_type =
                   function
                   | MtNil _x -> let o = o#loc _x in o
@@ -13333,7 +13281,6 @@ module Struct =
                       let o = o#loc _x in let o = o#module_expr _x_i1 in o
                   | MtAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method module_expr : module_expr -> 'self_type =
                   function
                   | MeNil _x -> let o = o#loc _x in o
@@ -13358,7 +13305,6 @@ module Struct =
                       let o = o#loc _x in let o = o#expr _x_i1 in o
                   | MeAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method module_binding : module_binding -> 'self_type =
                   function
                   | MbNil _x -> let o = o#loc _x in o
@@ -13377,7 +13323,6 @@ module Struct =
                       let o = o#module_type _x_i2 in o
                   | MbAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method meta_option :
                   'a.
                     ('self_type -> 'a -> 'self_type) ->
@@ -13387,7 +13332,6 @@ module Struct =
                     | ONone -> o
                     | OSome _x -> let o = _f_a o _x in o
                     | OAnt _x -> let o = o#string _x in o
-                  
                 method meta_list :
                   'a.
                     ('self_type -> 'a -> 'self_type) ->
@@ -13399,13 +13343,11 @@ module Struct =
                         let o = _f_a o _x in
                         let o = o#meta_list _f_a _x_i1 in o
                     | LAnt _x -> let o = o#string _x in o
-                  
                 method meta_bool : meta_bool -> 'self_type =
                   function
                   | BTrue -> o
                   | BFalse -> o
                   | BAnt _x -> let o = o#string _x in o
-                  
                 method match_case : match_case -> 'self_type =
                   function
                   | McNil _x -> let o = o#loc _x in o
@@ -13419,9 +13361,7 @@ module Struct =
                       let o = o#expr _x_i2 in let o = o#expr _x_i3 in o
                   | McAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method loc : loc -> 'self_type = o#unknown
-                  
                 method ident : ident -> 'self_type =
                   function
                   | IdAcc (_x, _x_i1, _x_i2) ->
@@ -13436,7 +13376,6 @@ module Struct =
                       let o = o#loc _x in let o = o#string _x_i1 in o
                   | IdAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method expr : expr -> 'self_type =
                   function
                   | ExNil _x -> let o = o#loc _x in o
@@ -13559,13 +13498,11 @@ module Struct =
                       let o = o#string _x_i1 in let o = o#expr _x_i2 in o
                   | ExPkg (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#module_expr _x_i1 in o
-                  
                 method direction_flag : direction_flag -> 'self_type =
                   function
                   | DiTo -> o
                   | DiDownto -> o
                   | DiAnt _x -> let o = o#string _x in o
-                  
                 method ctyp : ctyp -> 'self_type =
                   function
                   | TyNil _x -> let o = o#loc _x in o
@@ -13610,12 +13547,17 @@ module Struct =
                   | TyPol (_x, _x_i1, _x_i2) ->
                       let o = o#loc _x in
                       let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o
+                  | TyTypePol (_x, _x_i1, _x_i2) ->
+                      let o = o#loc _x in
+                      let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o
                   | TyQuo (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
                   | TyQuP (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
                   | TyQuM (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
+                  | TyAnP _x -> let o = o#loc _x in o
+                  | TyAnM _x -> let o = o#loc _x in o
                   | TyVrn (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
                   | TyRec (_x, _x_i1) ->
@@ -13668,7 +13610,6 @@ module Struct =
                       let o = o#loc _x in let o = o#module_type _x_i1 in o
                   | TyAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method class_type : class_type -> 'self_type =
                   function
                   | CtNil _x -> let o = o#loc _x in o
@@ -13697,7 +13638,6 @@ module Struct =
                       let o = o#class_type _x_i2 in o
                   | CtAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method class_str_item : class_str_item -> 'self_type =
                   function
                   | CrNil _x -> let o = o#loc _x in o
@@ -13739,7 +13679,6 @@ module Struct =
                       let o = o#ctyp _x_i3 in o
                   | CrAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method class_sig_item : class_sig_item -> 'self_type =
                   function
                   | CgNil _x -> let o = o#loc _x in o
@@ -13770,7 +13709,6 @@ module Struct =
                       let o = o#ctyp _x_i3 in o
                   | CgAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method class_expr : class_expr -> 'self_type =
                   function
                   | CeNil _x -> let o = o#loc _x in o
@@ -13807,7 +13745,6 @@ module Struct =
                       let o = o#class_expr _x_i2 in o
                   | CeAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method binding : binding -> 'self_type =
                   function
                   | BiNil _x -> let o = o#loc _x in o
@@ -13819,57 +13756,43 @@ module Struct =
                       let o = o#patt _x_i1 in let o = o#expr _x_i2 in o
                   | BiAnt (_x, _x_i1) ->
                       let o = o#loc _x in let o = o#string _x_i1 in o
-                  
                 method unknown : 'a. 'a -> 'self_type = fun _ -> o
-                  
               end
               
             let map_expr f =
               object
                 inherit map as super
-                  
                 method expr = fun x -> f (super#expr x)
-                  
               end
               
             let map_patt f =
               object
                 inherit map as super
-                  
                 method patt = fun x -> f (super#patt x)
-                  
               end
               
             let map_ctyp f =
               object
                 inherit map as super
-                  
                 method ctyp = fun x -> f (super#ctyp x)
-                  
               end
               
             let map_str_item f =
               object
                 inherit map as super
-                  
                 method str_item = fun x -> f (super#str_item x)
-                  
               end
               
             let map_sig_item f =
               object
                 inherit map as super
-                  
                 method sig_item = fun x -> f (super#sig_item x)
-                  
               end
               
             let map_loc f =
               object
                 inherit map as super
-                  
                 method loc = fun x -> f (super#loc x)
-                  
               end
               
           end
@@ -14470,9 +14393,9 @@ module Struct =
               | TyAnt (loc, _) -> error loc "antiquotation not allowed here"
               | TyOfAmp (_, _, _) | TyAmp (_, _, _) | TySta (_, _, _) |
                   TyCom (_, _, _) | TyVrn (_, _) | TyQuM (_, _) |
-                  TyQuP (_, _) | TyDcl (_, _, _, _, _) |
-                  TyObj (_, _, (RvAnt _)) | TyNil _ | TyTup (_, _) ->
-                  assert false
+                  TyQuP (_, _) | TyDcl (_, _, _, _, _) | TyAnP _ | TyAnM _ |
+                  TyTypePol (_, _, _) | TyObj (_, _, (RvAnt _)) | TyNil _ |
+                  TyTup (_, _) -> assert false
             and row_field =
               function
               | Ast.TyNil _ -> []
@@ -14499,7 +14422,7 @@ module Struct =
               match wc with
               | Ast.WcNil _ -> acc
               | Ast.WcTyp (_, (Ast.TyId (_, (Ast.IdLid (_, id)))), ct) ->
-                  (id, (ctyp ct)) :: acc
+                  (Lident id, (ctyp ct)) :: acc
               | Ast.WcAnd (_, wc1, wc2) ->
                   package_type_constraints wc1
                     (package_type_constraints wc2 acc)
@@ -14546,10 +14469,16 @@ module Struct =
             let mkvariant =
               function
               | Ast.TyId (loc, (Ast.IdUid (_, s))) ->
-                  ((conv_con s), [], (mkloc loc))
+                  ((conv_con s), [], None, (mkloc loc))
               | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) ->
-                  ((conv_con s), (List.map ctyp (list_of_ctyp t [])),
+                  ((conv_con s), (List.map ctyp (list_of_ctyp t [])), None,
                    (mkloc loc))
+              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))),
+                  (Ast.TyArr (_, t, u))) ->
+                  ((conv_con s), (List.map ctyp (list_of_ctyp t [])),
+                   (Some (ctyp u)), (mkloc loc))
+              | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) ->
+                  ((conv_con s), [], (Some (ctyp t)), (mkloc loc))
               | _ -> assert false
               
             let rec type_decl tl cl loc m pflag =
@@ -14616,6 +14545,19 @@ module Struct =
               | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc
               | _ -> assert false
               
+            let rec optional_type_parameters t acc =
+              match t with
+              | Ast.TyApp (_, t1, t2) ->
+                  optional_type_parameters t1
+                    (optional_type_parameters t2 acc)
+              | Ast.TyQuP (_, s) -> ((Some s), (true, false)) :: acc
+              | Ast.TyAnP _loc -> (None, (true, false)) :: acc
+              | Ast.TyQuM (_, s) -> ((Some s), (false, true)) :: acc
+              | Ast.TyAnM _loc -> (None, (false, true)) :: acc
+              | Ast.TyQuo (_, s) -> ((Some s), (false, false)) :: acc
+              | Ast.TyAny _loc -> (None, (false, false)) :: acc
+              | _ -> assert false
+              
             let rec class_parameters t acc =
               match t with
               | Ast.TyCom (_, t1, t2) ->
@@ -14628,7 +14570,8 @@ module Struct =
             let rec type_parameters_and_type_name t acc =
               match t with
               | Ast.TyApp (_, t1, t2) ->
-                  type_parameters_and_type_name t1 (type_parameters t2 acc)
+                  type_parameters_and_type_name t1
+                    (optional_type_parameters t2 acc)
               | Ast.TyId (_, i) -> ((ident i), acc)
               | _ -> assert false
               
@@ -14821,6 +14764,7 @@ module Struct =
               | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i))
               | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None))
               | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p))
+              | PaMod (loc, m) -> mkpat loc (Ppat_unpack m)
               | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _
                  as p) -> error (loc_of_patt p) "invalid pattern"
             and mklabpat =
@@ -14871,6 +14815,49 @@ module Struct =
             let list_of_opt_ctyp ot acc =
               match ot with | Ast.TyNil _ -> acc | t -> list_of_ctyp t acc
               
+            let varify_constructors var_names =
+              let rec loop t =
+                let desc =
+                  match t.ptyp_desc with
+                  | Ptyp_any -> Ptyp_any
+                  | Ptyp_var x -> Ptyp_var x
+                  | Ptyp_arrow (label, core_type, core_type') ->
+                      Ptyp_arrow (label, (loop core_type), (loop core_type'))
+                  | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+                  | Ptyp_constr ((Lident s), []) when List.mem s var_names ->
+                      Ptyp_var ("&" ^ s)
+                  | Ptyp_constr (longident, lst) ->
+                      Ptyp_constr (longident, (List.map loop lst))
+                  | Ptyp_object lst ->
+                      Ptyp_object (List.map loop_core_field lst)
+                  | Ptyp_class (longident, lst, lbl_list) ->
+                      Ptyp_class ((longident, (List.map loop lst), lbl_list))
+                  | Ptyp_alias (core_type, string) ->
+                      Ptyp_alias (((loop core_type), string))
+                  | Ptyp_variant (row_field_list, flag, lbl_lst_option) ->
+                      Ptyp_variant
+                        (((List.map loop_row_field row_field_list), flag,
+                          lbl_lst_option))
+                  | Ptyp_poly (string_lst, core_type) ->
+                      Ptyp_poly ((string_lst, (loop core_type)))
+                  | Ptyp_package (longident, lst) ->
+                      Ptyp_package
+                        ((longident,
+                          (List.map (fun (n, typ) -> (n, (loop typ))) lst)))
+                in { (t) with ptyp_desc = desc; }
+              and loop_core_field t =
+                let desc =
+                  match t.pfield_desc with
+                  | Pfield ((n, typ)) -> Pfield ((n, (loop typ)))
+                  | Pfield_var -> Pfield_var
+                in { (t) with pfield_desc = desc; }
+              and loop_row_field x =
+                match x with
+                | Rtag ((label, flag, lst)) ->
+                    Rtag ((label, flag, (List.map loop lst)))
+                | Rinherit t -> Rinherit (loop t)
+              in loop
+              
             let rec expr =
               function
               | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) ->
@@ -15040,7 +15027,7 @@ module Struct =
                      with
                      | Failure _ ->
                          error loc
-                           "Integer literal exceeds the range of representable integers of type int64.1")
+                           "Integer literal exceeds the range of representable integers of type int64")
                   in mkexp loc (Pexp_constant (Const_int64 i64))
               | ExNativeInt (loc, s) ->
                   let nati =
@@ -15122,9 +15109,12 @@ module Struct =
               | Ast.ExOpI (loc, i, e) ->
                   mkexp loc (Pexp_open ((long_uident i), (expr e)))
               | Ast.ExPkg (loc, (Ast.MeTyc (_, me, pt))) ->
-                  mkexp loc (Pexp_pack ((module_expr me), (package_type pt)))
-              | Ast.ExPkg (loc, _) ->
-                  error loc "(module_expr : package_type) expected here"
+                  mkexp loc
+                    (Pexp_constraint
+                       (((mkexp loc (Pexp_pack (module_expr me))),
+                         (Some (mktyp loc (Ptyp_package (package_type pt)))),
+                         None)))
+              | Ast.ExPkg (loc, me) -> mkexp loc (Pexp_pack (module_expr me))
               | ExFUN (loc, i, e) -> mkexp loc (Pexp_newtype (i, (expr e)))
               | Ast.ExCom (loc, _, _) ->
                   error loc "expr, expr: not allowed here"
@@ -15152,6 +15142,40 @@ module Struct =
             and binding x acc =
               match x with
               | Ast.BiAnd (_, x, y) -> binding x (binding y acc)
+              | Ast.BiEq (_loc, (Ast.PaId (_, (Ast.IdLid (_, bind_name)))),
+                  (Ast.ExTyc (_, e, (TyTypePol (_, vs, ty))))) ->
+                  let rec id_to_string x =
+                    (match x with
+                     | Ast.TyId (_, (Ast.IdLid (_, x))) -> [ x ]
+                     | Ast.TyApp (_, x, y) ->
+                         (id_to_string x) @ (id_to_string y)
+                     | _ -> assert false) in
+                  let vars = id_to_string vs in
+                  let ampersand_vars = List.map (fun x -> "&" ^ x) vars in
+                  let rec merge_quoted_vars lst =
+                    (match lst with
+                     | [ x ] -> x
+                     | x :: y -> Ast.TyApp (_loc, x, (merge_quoted_vars y))
+                     | [] -> assert false) in
+                  let ty' = varify_constructors vars (ctyp ty) in
+                  let mkexp = mkexp _loc in
+                  let mkpat = mkpat _loc in
+                  let e =
+                    mkexp
+                      (Pexp_constraint ((expr e), (Some (ctyp ty)), None)) in
+                  let rec mk_newtypes x =
+                    (match x with
+                     | [ newtype ] -> mkexp (Pexp_newtype ((newtype, e)))
+                     | newtype :: newtypes ->
+                         mkexp
+                           (Pexp_newtype ((newtype, (mk_newtypes newtypes))))
+                     | [] -> assert false) in
+                  let pat =
+                    mkpat
+                      (Ppat_constraint
+                         (((mkpat (Ppat_var bind_name)),
+                           (mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in
+                  let e = mk_newtypes vars in (pat, e) :: acc
               | Ast.BiEq (_loc, p,
                   (Ast.ExTyc (_, e, (Ast.TyPol (_, vs, ty))))) ->
                   ((patt (Ast.PaTyc (_loc, p, (Ast.TyPol (_loc, vs, ty))))),
@@ -15194,7 +15218,9 @@ module Struct =
                       cl
                   in
                     (c,
-                     (type_decl (List.fold_right type_parameters tl []) cl td)) ::
+                     (type_decl
+                        (List.fold_right optional_type_parameters tl []) cl
+                        td)) ::
                       acc
               | _ -> assert false
             and module_type =
@@ -15211,6 +15237,8 @@ module Struct =
                   mkmty loc (Pmty_signature (sig_item sl []))
               | Ast.MtWit (loc, mt, wc) ->
                   mkmty loc (Pmty_with ((module_type mt), (mkwithc wc [])))
+              | Ast.MtOf (loc, me) ->
+                  mkmty loc (Pmty_typeof (module_expr me))
               | Ast.MtAnt (_, _) -> assert false
             and sig_item s l =
               match s with
@@ -15291,9 +15319,15 @@ module Struct =
                   mkmod loc
                     (Pmod_constraint ((module_expr me), (module_type mt)))
               | Ast.MePkg (loc, (Ast.ExTyc (_, e, (Ast.TyPkg (_, pt))))) ->
-                  mkmod loc (Pmod_unpack ((expr e), (package_type pt)))
-              | Ast.MePkg (loc, _) ->
-                  error loc "(value expr) not supported yet"
+                  mkmod loc
+                    (Pmod_unpack
+                       (mkexp loc
+                          (Pexp_constraint
+                             (((expr e),
+                               (Some
+                                  (mktyp loc (Ptyp_package (package_type pt)))),
+                               None)))))
+              | Ast.MePkg (loc, e) -> mkmod loc (Pmod_unpack (expr e))
               | Ast.MeAnt (loc, _) ->
                   error loc "antiquotation in module_expr"
             and str_item s l =
@@ -15327,6 +15361,9 @@ module Struct =
                   (Ast.OSome i)) ->
                   (mkstr loc (Pstr_exn_rebind ((conv_con s), (ident i)))) ::
                     l
+              | Ast.StExc (loc,
+                  (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)),
+                  (Ast.OSome _)) -> error loc "type in exception alias"
               | StExc (_, _, _) -> assert false
               | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l
               | StExt (loc, n, t, sl) ->
@@ -15551,14 +15588,12 @@ module Struct =
           struct
             class clean_ast =
               object inherit Ast.map as super
-                       
                 method with_constr =
                   fun wc ->
                     match super#with_constr wc with
                     | Ast.WcAnd (_, (Ast.WcNil _), wc) |
                         Ast.WcAnd (_, wc, (Ast.WcNil _)) -> wc
                     | wc -> wc
-                  
                 method expr =
                   fun e ->
                     match super#expr e with
@@ -15569,7 +15604,6 @@ module Struct =
                         Ast.ExSem (_, (Ast.ExNil _), e) |
                         Ast.ExSem (_, e, (Ast.ExNil _)) -> e
                     | e -> e
-                  
                 method patt =
                   fun p ->
                     match super#patt p with
@@ -15581,35 +15615,30 @@ module Struct =
                         Ast.PaSem (_, (Ast.PaNil _), p) |
                         Ast.PaSem (_, p, (Ast.PaNil _)) -> p
                     | p -> p
-                  
                 method match_case =
                   fun mc ->
                     match super#match_case mc with
                     | Ast.McOr (_, (Ast.McNil _), mc) |
                         Ast.McOr (_, mc, (Ast.McNil _)) -> mc
                     | mc -> mc
-                  
                 method binding =
                   fun bi ->
                     match super#binding bi with
                     | Ast.BiAnd (_, (Ast.BiNil _), bi) |
                         Ast.BiAnd (_, bi, (Ast.BiNil _)) -> bi
                     | bi -> bi
-                  
                 method rec_binding =
                   fun rb ->
                     match super#rec_binding rb with
                     | Ast.RbSem (_, (Ast.RbNil _), bi) |
                         Ast.RbSem (_, bi, (Ast.RbNil _)) -> bi
                     | bi -> bi
-                  
                 method module_binding =
                   fun mb ->
                     match super#module_binding mb with
                     | Ast.MbAnd (_, (Ast.MbNil _), mb) |
                         Ast.MbAnd (_, mb, (Ast.MbNil _)) -> mb
                     | mb -> mb
-                  
                 method ctyp =
                   fun t ->
                     match super#ctyp t with
@@ -15632,7 +15661,6 @@ module Struct =
                         Ast.TySta (_, (Ast.TyNil _), t) |
                         Ast.TySta (_, t, (Ast.TyNil _)) -> t
                     | t -> t
-                  
                 method sig_item =
                   fun sg ->
                     match super#sig_item sg with
@@ -15640,7 +15668,6 @@ module Struct =
                         Ast.SgSem (_, sg, (Ast.SgNil _)) -> sg
                     | Ast.SgTyp (loc, (Ast.TyNil _)) -> Ast.SgNil loc
                     | sg -> sg
-                  
                 method str_item =
                   fun st ->
                     match super#str_item st with
@@ -15649,41 +15676,35 @@ module Struct =
                     | Ast.StTyp (loc, (Ast.TyNil _)) -> Ast.StNil loc
                     | Ast.StVal (loc, _, (Ast.BiNil _)) -> Ast.StNil loc
                     | st -> st
-                  
                 method module_type =
                   fun mt ->
                     match super#module_type mt with
                     | Ast.MtWit (_, mt, (Ast.WcNil _)) -> mt
                     | mt -> mt
-                  
                 method class_expr =
                   fun ce ->
                     match super#class_expr ce with
                     | Ast.CeAnd (_, (Ast.CeNil _), ce) |
                         Ast.CeAnd (_, ce, (Ast.CeNil _)) -> ce
                     | ce -> ce
-                  
                 method class_type =
                   fun ct ->
                     match super#class_type ct with
                     | Ast.CtAnd (_, (Ast.CtNil _), ct) |
                         Ast.CtAnd (_, ct, (Ast.CtNil _)) -> ct
                     | ct -> ct
-                  
                 method class_sig_item =
                   fun csg ->
                     match super#class_sig_item csg with
                     | Ast.CgSem (_, (Ast.CgNil _), csg) |
                         Ast.CgSem (_, csg, (Ast.CgNil _)) -> csg
                     | csg -> csg
-                  
                 method class_str_item =
                   fun cst ->
                     match super#class_str_item cst with
                     | Ast.CrSem (_, (Ast.CrNil _), cst) |
                         Ast.CrSem (_, cst, (Ast.CrNil _)) -> cst
                     | cst -> cst
-                  
               end
               
           end
@@ -15878,10 +15899,7 @@ module Struct =
             class ['accu] c_fold_pattern_vars :
               (string -> 'accu -> 'accu) ->
                 'accu ->
-                  object inherit Ast.fold
-                            val acc : 'accu
-                               method acc : 'accu
-                                 
+                  object inherit Ast.fold val acc : 'accu method acc : 'accu
                   end
               
             val fold_pattern_vars :
@@ -15893,21 +15911,13 @@ module Struct =
                   'accu ->
                     object ('self_type)
                       inherit Ast.fold
-                        
                       val free : 'accu
-                        
                       val env : S.t
-                        
                       method free : 'accu
-                        
                       method set_env : S.t -> 'self_type
-                        
                       method add_atom : string -> 'self_type
-                        
                       method add_patt : Ast.patt -> 'self_type
-                        
                       method add_binding : Ast.binding -> 'self_type
-                        
                     end
               
             val free_vars : S.t -> Ast.expr -> S.t
@@ -15922,18 +15932,14 @@ module Struct =
               
             class ['accu] c_fold_pattern_vars f init =
               object inherit Ast.fold as super
-                       
                 val acc = init
-                  
                 method acc : 'accu = acc
-                  
                 method patt =
                   function
                   | Ast.PaId (_, (Ast.IdLid (_, s))) |
                       Ast.PaLab (_, s, (Ast.PaNil _)) |
                       Ast.PaOlb (_, s, (Ast.PaNil _)) -> {< acc = f s acc; >}
                   | p -> super#patt p
-                  
               end
               
             let fold_pattern_vars f p init =
@@ -15951,23 +15957,15 @@ module Struct =
                     ?(env_init = S.empty) free_init =
               object (o)
                 inherit Ast.fold as super
-                  
                 val free = (free_init : 'accu)
-                  
                 val env = (env_init : S.t)
-                  
                 method free = free
-                  
                 method set_env = fun env -> {< env = env; >}
-                  
                 method add_atom = fun s -> {< env = S.add s env; >}
-                  
                 method add_patt =
                   fun p -> {< env = fold_pattern_vars S.add p env; >}
-                  
                 method add_binding =
                   fun bi -> {< env = fold_binding_vars S.add bi env; >}
-                  
                 method expr =
                   function
                   | Ast.ExId (_, (Ast.IdLid (_, s))) |
@@ -15985,13 +15983,11 @@ module Struct =
                   | Ast.ExObj (_, p, cst) ->
                       ((o#add_patt p)#class_str_item cst)#set_env env
                   | e -> super#expr e
-                  
                 method match_case =
                   function
                   | Ast.McArr (_, p, e1, e2) ->
                       (((o#add_patt p)#expr e1)#expr e2)#set_env env
                   | m -> super#match_case m
-                  
                 method str_item =
                   function
                   | Ast.StExt (_, s, t, _) -> (o#ctyp t)#add_atom s
@@ -16000,7 +15996,6 @@ module Struct =
                   | Ast.StVal (_, Ast.ReRecursive, bi) ->
                       (o#add_binding bi)#binding bi
                   | st -> super#str_item st
-                  
                 method class_expr =
                   function
                   | Ast.CeFun (_, p, ce) ->
@@ -16014,7 +16009,6 @@ module Struct =
                   | Ast.CeStr (_, p, cst) ->
                       ((o#add_patt p)#class_str_item cst)#set_env env
                   | ce -> super#class_expr ce
-                  
                 method class_str_item =
                   function
                   | (Ast.CrInh (_, _, _, "") as cst) ->
@@ -16023,12 +16017,10 @@ module Struct =
                   | Ast.CrVal (_, s, _, _, e) -> (o#expr e)#add_atom s
                   | Ast.CrVvr (_, s, _, t) -> (o#ctyp t)#add_atom s
                   | cst -> super#class_str_item cst
-                  
                 method module_expr =
                   function
                   | Ast.MeStr (_, st) -> (o#str_item st)#set_env env
                   | me -> super#module_expr me
-                  
               end
               
             let free_vars env_init e =
@@ -18633,191 +18625,113 @@ module Printers =
                   unit ->
                     object ('a)
                       method interf : formatter -> Ast.sig_item -> unit
-                        
                       method implem : formatter -> Ast.str_item -> unit
-                        
                       method sig_item : formatter -> Ast.sig_item -> unit
-                        
                       method str_item : formatter -> Ast.str_item -> unit
-                        
                       val pipe : bool
-                        
                       val semi : bool
-                        
                       val semisep : sep
-                        
+                      val no_semisep : sep
                       method value_val : string
-                        
                       method value_let : string
-                        
                       method andsep : sep
-                        
                       method anti : formatter -> string -> unit
-                        
                       method class_declaration :
                         formatter -> Ast.class_expr -> unit
-                        
                       method class_expr : formatter -> Ast.class_expr -> unit
-                        
                       method class_sig_item :
                         formatter -> Ast.class_sig_item -> unit
-                        
                       method class_str_item :
                         formatter -> Ast.class_str_item -> unit
-                        
                       method class_type : formatter -> Ast.class_type -> unit
-                        
                       method constrain :
                         formatter -> (Ast.ctyp * Ast.ctyp) -> unit
-                        
                       method ctyp : formatter -> Ast.ctyp -> unit
-                        
                       method ctyp1 : formatter -> Ast.ctyp -> unit
-                        
                       method constructor_type : formatter -> Ast.ctyp -> unit
-                        
                       method dot_expr : formatter -> Ast.expr -> unit
-                        
                       method apply_expr : formatter -> Ast.expr -> unit
-                        
                       method expr : formatter -> Ast.expr -> unit
-                        
                       method expr_list : formatter -> Ast.expr list -> unit
-                        
                       method expr_list_cons :
                         bool -> formatter -> Ast.expr -> unit
-                        
                       method fun_binding : formatter -> fun_binding -> unit
-                        
                       method functor_arg :
                         formatter -> (string * Ast.module_type) -> unit
-                        
                       method functor_args :
                         formatter -> (string * Ast.module_type) list -> unit
-                        
                       method ident : formatter -> Ast.ident -> unit
-                        
                       method numeric : formatter -> string -> string -> unit
-                        
                       method binding : formatter -> Ast.binding -> unit
-                        
                       method record_binding :
                         formatter -> Ast.rec_binding -> unit
-                        
                       method match_case : formatter -> Ast.match_case -> unit
-                        
                       method match_case_aux :
                         formatter -> Ast.match_case -> unit
-                        
                       method mk_expr_list :
                         Ast.expr -> ((Ast.expr list) * (Ast.expr option))
-                        
                       method mk_patt_list :
                         Ast.patt -> ((Ast.patt list) * (Ast.patt option))
-                        
                       method simple_module_expr :
                         formatter -> Ast.module_expr -> unit
-                        
                       method module_expr :
                         formatter -> Ast.module_expr -> unit
-                        
                       method module_expr_get_functor_args :
                         (string * Ast.module_type) list ->
                           Ast.module_expr ->
                             (((string * Ast.module_type) list) * Ast.
                              module_expr * (Ast.module_type option))
-                        
                       method module_rec_binding :
                         formatter -> Ast.module_binding -> unit
-                        
                       method module_type :
                         formatter -> Ast.module_type -> unit
-                        
                       method override_flag :
                         formatter -> Ast.override_flag -> unit
-                        
                       method mutable_flag :
                         formatter -> Ast.mutable_flag -> unit
-                        
                       method direction_flag :
                         formatter -> Ast.direction_flag -> unit
-                        
                       method rec_flag : formatter -> Ast.rec_flag -> unit
-                        
                       method node : formatter -> 'b -> ('b -> Loc.t) -> unit
-                        
                       method patt : formatter -> Ast.patt -> unit
-                        
                       method patt1 : formatter -> Ast.patt -> unit
-                        
                       method patt2 : formatter -> Ast.patt -> unit
-                        
                       method patt3 : formatter -> Ast.patt -> unit
-                        
                       method patt4 : formatter -> Ast.patt -> unit
-                        
                       method patt5 : formatter -> Ast.patt -> unit
-                        
                       method patt_tycon : formatter -> Ast.patt -> unit
-                        
                       method patt_expr_fun_args :
                         formatter -> (fun_binding * Ast.expr) -> unit
-                        
                       method patt_class_expr_fun_args :
                         formatter -> (Ast.patt * Ast.class_expr) -> unit
-                        
                       method print_comments_before :
                         Loc.t -> formatter -> unit
-                        
                       method private_flag :
                         formatter -> Ast.private_flag -> unit
-                        
                       method virtual_flag :
                         formatter -> Ast.virtual_flag -> unit
-                        
                       method quoted_string : formatter -> string -> unit
-                        
                       method raise_match_failure : formatter -> Loc.t -> unit
-                        
                       method reset : 'a
-                        
                       method reset_semi : 'a
-                        
                       method semisep : sep
-                        
                       method set_comments : bool -> 'a
-                        
                       method set_curry_constr : bool -> 'a
-                        
                       method set_loc_and_comments : 'a
-                        
                       method set_semisep : sep -> 'a
-                        
                       method simple_ctyp : formatter -> Ast.ctyp -> unit
-                        
                       method simple_expr : formatter -> Ast.expr -> unit
-                        
                       method simple_patt : formatter -> Ast.patt -> unit
-                        
                       method seq : formatter -> Ast.expr -> unit
-                        
                       method string : formatter -> string -> unit
-                        
                       method sum_type : formatter -> Ast.ctyp -> unit
-                        
                       method type_params : formatter -> Ast.ctyp list -> unit
-                        
                       method class_params : formatter -> Ast.ctyp -> unit
-                        
                       method under_pipe : 'a
-                        
                       method under_semi : 'a
-                        
                       method var : formatter -> string -> unit
-                        
                       method with_constraint :
                         formatter -> Ast.with_constr -> unit
-                        
                     end
               
             val with_outfile :
@@ -19008,43 +18922,26 @@ module Printers =
                     ?(comments = true) () =
               object (o)
                 val pipe = false
-                  
                 val semi = false
-                  
                 method under_pipe = {< pipe = true; >}
-                  
                 method under_semi = {< semi = true; >}
-                  
                 method reset_semi = {< semi = false; >}
-                  
                 method reset = {< pipe = false; semi = false; >}
-                  
                 val semisep = (";;" : sep)
-                  
+                val no_semisep = ("" : sep)
                 val mode = if comments then `comments else `no_comments
-                  
                 val curry_constr = init_curry_constr
-                  
                 val var_conversion = false
-                  
                 method andsep : sep = "@]@ @[<2>and@ "
-                  
                 method value_val = "val"
-                  
                 method value_let = "let"
-                  
                 method semisep = semisep
-                  
                 method set_semisep = fun s -> {< semisep = s; >}
-                  
                 method set_comments =
                   fun b ->
                     {< mode = if b then `comments else `no_comments; >}
-                  
                 method set_loc_and_comments = {< mode = `loc_and_comments; >}
-                  
                 method set_curry_constr = fun b -> {< curry_constr = b; >}
-                  
                 method print_comments_before =
                   fun loc f ->
                     match mode with
@@ -19059,7 +18956,6 @@ module Printers =
                             (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump)
                             (CommentFilter.take_stream comment_filter)
                     | _ -> ()
-                  
                 method var =
                   fun f ->
                     function
@@ -19087,14 +18983,12 @@ module Printers =
                                     (sprintf
                                        "Bad token used as an identifier: %s"
                                        (Token.to_string tok))))
-                  
                 method type_params =
                   fun f ->
                     function
                     | [] -> ()
                     | [ x ] -> pp f "%a@ " o#ctyp x
                     | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l
-                  
                 method class_params =
                   fun f ->
                     function
@@ -19102,44 +18996,37 @@ module Printers =
                         pp f "@[<1>%a,@ %a@]" o#class_params t1
                           o#class_params t2
                     | x -> o#ctyp f x
-                  
                 method override_flag =
                   fun f ->
                     function
                     | Ast.OvOverride -> pp f "!"
                     | Ast.OvNil -> ()
                     | Ast.OvAnt s -> o#anti f s
-                  
                 method mutable_flag =
                   fun f ->
                     function
                     | Ast.MuMutable -> pp f "mutable@ "
                     | Ast.MuNil -> ()
                     | Ast.MuAnt s -> o#anti f s
-                  
                 method rec_flag =
                   fun f ->
                     function
                     | Ast.ReRecursive -> pp f "rec@ "
                     | Ast.ReNil -> ()
                     | Ast.ReAnt s -> o#anti f s
-                  
                 method virtual_flag =
                   fun f ->
                     function
                     | Ast.ViVirtual -> pp f "virtual@ "
                     | Ast.ViNil -> ()
                     | Ast.ViAnt s -> o#anti f s
-                  
                 method private_flag =
                   fun f ->
                     function
                     | Ast.PrPrivate -> pp f "private@ "
                     | Ast.PrNil -> ()
                     | Ast.PrAnt s -> o#anti f s
-                  
                 method anti = fun f s -> pp f "$%s$" s
-                  
                 method seq =
                   fun f ->
                     function
@@ -19147,14 +19034,12 @@ module Printers =
                         pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2
                     | Ast.ExSeq (_, e) -> o#seq f e
                     | e -> o#expr f e
-                  
                 method match_case =
                   fun f ->
                     function
                     | Ast.McNil _loc ->
                         pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc
                     | a -> o#match_case_aux f a
-                  
                 method match_case_aux =
                   fun f ->
                     function
@@ -19168,13 +19053,11 @@ module Printers =
                     | Ast.McArr (_, p, w, e) ->
                         pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" o#patt p
                           o#under_pipe#expr w o#under_pipe#expr e
-                  
                 method fun_binding =
                   fun f ->
                     function
                     | `patt p -> o#simple_patt f p
                     | `newtype i -> pp f "(type %s)" i
-                  
                 method binding =
                   fun f bi ->
                     let () = o#node f bi Ast.loc_of_binding
@@ -19199,7 +19082,6 @@ module Printers =
                                  pp f "%a @[<0>%a=@]@ %a" o#simple_patt p
                                    (list' o#fun_binding "" "@ ") pl o#expr e)
                       | Ast.BiAnt (_, s) -> o#anti f s
-                  
                 method record_binding =
                   fun f bi ->
                     let () = o#node f bi Ast.loc_of_rec_binding
@@ -19212,7 +19094,6 @@ module Printers =
                           (o#under_semi#record_binding f b1;
                            o#under_semi#record_binding f b2)
                       | Ast.RbAnt (_, s) -> o#anti f s
-                  
                 method mk_patt_list =
                   function
                   | Ast.PaApp (_,
@@ -19222,7 +19103,6 @@ module Printers =
                       let (pl, c) = o#mk_patt_list p2 in ((p1 :: pl), c)
                   | Ast.PaId (_, (Ast.IdUid (_, "[]"))) -> ([], None)
                   | p -> ([], (Some p))
-                  
                 method mk_expr_list =
                   function
                   | Ast.ExApp (_,
@@ -19232,7 +19112,6 @@ module Printers =
                       let (el, c) = o#mk_expr_list e2 in ((e1 :: el), c)
                   | Ast.ExId (_, (Ast.IdUid (_, "[]"))) -> ([], None)
                   | e -> ([], (Some e))
-                  
                 method expr_list =
                   fun f ->
                     function
@@ -19241,7 +19120,6 @@ module Printers =
                     | el ->
                         pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ")
                           el
-                  
                 method expr_list_cons =
                   fun simple f e ->
                     let (el, c) = o#mk_expr_list e
@@ -19253,41 +19131,33 @@ module Printers =
                            then pp f "@[<2>(%a)@]"
                            else pp f "@[<2>%a@]")
                             (list o#under_semi#dot_expr " ::@ ") (el @ [ x ])
-                  
                 method patt_expr_fun_args =
                   fun f (p, e) ->
                     let (pl, e) = expr_fun_args e
                     in
                       pp f "%a@ ->@ %a" (list o#fun_binding "@ ") (p :: pl)
                         o#expr e
-                  
                 method patt_class_expr_fun_args =
                   fun f (p, ce) ->
                     let (pl, ce) = class_expr_fun_args ce
                     in
                       pp f "%a =@]@ %a" (list o#simple_patt "@ ") (p :: pl)
                         o#class_expr ce
-                  
                 method constrain =
                   fun f (t1, t2) ->
                     pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2
-                  
                 method sum_type =
                   fun f t ->
                     match Ast.list_of_ctyp t [] with
                     | [] -> ()
                     | ts -> pp f "@[<hv0>| %a@]" (list o#ctyp "@ | ") ts
-                  
                 method string = fun f -> pp f "%s"
-                  
                 method quoted_string = fun f -> pp f "%S"
-                  
                 method numeric =
                   fun f num suff ->
                     if num.[0] = '-'
                     then pp f "(%s%s)" num suff
                     else pp f "%s%s" num suff
-                  
                 method module_expr_get_functor_args =
                   fun accu ->
                     function
@@ -19296,13 +19166,10 @@ module Printers =
                     | Ast.MeTyc (_, me, mt) ->
                         ((List.rev accu), me, (Some mt))
                     | me -> ((List.rev accu), me, None)
-                  
                 method functor_args = fun f -> list o#functor_arg "@ " f
-                  
                 method functor_arg =
                   fun f (s, mt) ->
                     pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt
-                  
                 method module_rec_binding =
                   fun f ->
                     function
@@ -19317,14 +19184,12 @@ module Printers =
                          pp f o#andsep;
                          o#module_rec_binding f mb2)
                     | Ast.MbAnt (_, s) -> o#anti f s
-                  
                 method class_declaration =
                   fun f ->
                     function
                     | Ast.CeTyc (_, ce, ct) ->
                         pp f "%a :@ %a" o#class_expr ce o#class_type ct
                     | ce -> o#class_expr f ce
-                  
                 method raise_match_failure =
                   fun f _loc ->
                     let n = Loc.file_name _loc in
@@ -19343,11 +19208,9 @@ module Printers =
                                        (Ast.safe_string_escaped n))))),
                                  (Ast.ExInt (_loc, (string_of_int l))))),
                               (Ast.ExInt (_loc, (string_of_int c)))))))
-                  
                 method node : 'a. formatter -> 'a -> ('a -> Loc.t) -> unit =
                   fun f node loc_of_node ->
                     o#print_comments_before (loc_of_node node) f
-                  
                 method ident =
                   fun f i ->
                     let () = o#node f i Ast.loc_of_ident
@@ -19359,9 +19222,7 @@ module Printers =
                           pp f "%a@,(%a)" o#ident i1 o#ident i2
                       | Ast.IdAnt (_, s) -> o#anti f s
                       | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s
-                  
                 method private var_ident = {< var_conversion = true; >}#ident
-                  
                 method expr =
                   fun f e ->
                     let () = o#node f e Ast.loc_of_expr
@@ -19471,7 +19332,6 @@ module Printers =
                             "@[<hv0>@[<hv2>object @[<2>(%a)@]@ %a@]@ end@]"
                             o#patt p o#class_str_item cst
                       | e -> o#apply_expr f e
-                  
                 method apply_expr =
                   fun f e ->
                     let () = o#node f e Ast.loc_of_expr
@@ -19479,7 +19339,6 @@ module Printers =
                       match e with
                       | Ast.ExNew (_, i) -> pp f "@[<2>new@ %a@]" o#ident i
                       | e -> o#dot_expr f e
-                  
                 method dot_expr =
                   fun f e ->
                     let () = o#node f e Ast.loc_of_expr
@@ -19497,7 +19356,6 @@ module Printers =
                       | Ast.ExSnd (_, e, s) ->
                           pp f "@[<2>%a#@,%s@]" o#dot_expr e s
                       | e -> o#simple_expr f e
-                  
                 method simple_expr =
                   fun f e ->
                     let () = o#node f e Ast.loc_of_expr
@@ -19571,14 +19429,12 @@ module Printers =
                           Ast.ExAsr (_, _) | Ast.ExAsf _ | Ast.ExLaz (_, _) |
                           Ast.ExNew (_, _) | Ast.ExObj (_, _, _) ->
                           pp f "(%a)" o#reset#expr e
-                  
                 method direction_flag =
                   fun f b ->
                     match b with
                     | Ast.DiTo -> pp_print_string f "to"
                     | Ast.DiDownto -> pp_print_string f "downto"
                     | Ast.DiAnt s -> o#anti f s
-                  
                 method patt =
                   fun f p ->
                     let () = o#node f p Ast.loc_of_patt
@@ -19591,16 +19447,13 @@ module Printers =
                       | Ast.PaSem (_, p1, p2) ->
                           pp f "%a;@ %a" o#patt p1 o#patt p2
                       | p -> o#patt1 f p
-                  
                 method patt1 =
                   fun f ->
                     function
                     | Ast.PaOrp (_, p1, p2) ->
                         pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2
                     | p -> o#patt2 f p
-                  
                 method patt2 = fun f p -> o#patt3 f p
-                  
                 method patt3 =
                   fun f ->
                     function
@@ -19609,7 +19462,6 @@ module Printers =
                     | Ast.PaCom (_, p1, p2) ->
                         pp f "%a,@ %a" o#patt3 p1 o#patt3 p2
                     | p -> o#patt4 f p
-                  
                 method patt4 =
                   fun f ->
                     function
@@ -19627,7 +19479,6 @@ module Printers =
                                pp f "@[<2>%a@]" (list o#patt5 " ::@ ")
                                  (pl @ [ x ]))
                     | p -> o#patt5 f p
-                  
                 method patt5 =
                   fun f ->
                     function
@@ -19662,7 +19513,6 @@ module Printers =
                                    pp f "@[<2>%a@ (%a)@]" o#patt5 a
                                      (list o#simple_patt ",@ ") al)
                     | p -> o#simple_patt f p
-                  
                 method simple_patt =
                   fun f p ->
                     let () = o#node f p Ast.loc_of_patt
@@ -19672,6 +19522,7 @@ module Printers =
                       | Ast.PaId (_, i) -> o#var_ident f i
                       | Ast.PaAnt (_, s) -> o#anti f s
                       | Ast.PaAny _ -> pp f "_"
+                      | Ast.PaMod (_, m) -> pp f "(module %s)" m
                       | Ast.PaTup (_, p) -> pp f "@[<1>(%a)@]" o#patt3 p
                       | Ast.PaRec (_, p) -> pp f "@[<hv2>{@ %a@]@ }" o#patt p
                       | Ast.PaStr (_, s) -> pp f "\"%s\"" s
@@ -19704,14 +19555,12 @@ module Printers =
                            Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) |
                            Ast.PaEq (_, _, _) | Ast.PaLaz (_, _)
                          as p) -> pp f "@[<1>(%a)@]" o#patt p
-                  
                 method patt_tycon =
                   fun f ->
                     function
                     | Ast.PaTyc (_, p, t) ->
                         pp f "%a :@ %a" o#patt p o#ctyp t
                     | p -> o#patt f p
-                  
                 method simple_ctyp =
                   fun f t ->
                     let () = o#node f t Ast.loc_of_ctyp
@@ -19720,6 +19569,8 @@ module Printers =
                       | Ast.TyId (_, i) -> o#ident f i
                       | Ast.TyAnt (_, s) -> o#anti f s
                       | Ast.TyAny _ -> pp f "_"
+                      | Ast.TyAnP _ -> pp f "+_"
+                      | Ast.TyAnM _ -> pp f "-_"
                       | Ast.TyLab (_, s, t) ->
                           pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t
                       | Ast.TyOlb (_, s, t) ->
@@ -19754,7 +19605,6 @@ module Printers =
                           pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2
                       | Ast.TyNil _ -> assert false
                       | t -> pp f "@[<1>(%a)@]" o#ctyp t
-                  
                 method ctyp =
                   fun f t ->
                     let () = o#node f t Ast.loc_of_ctyp
@@ -19799,7 +19649,6 @@ module Printers =
                            then pp f "@ %a" (list o#constrain "@ ") cl
                            else ())
                       | t -> o#ctyp1 f t
-                  
                 method ctyp1 =
                   fun f ->
                     function
@@ -19816,10 +19665,14 @@ module Printers =
                         in
                           pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") (a :: al)
                             o#ctyp t2
+                    | Ast.TyTypePol ((_, t1, t2)) ->
+                        let (a, al) = get_ctyp_args t1 []
+                        in
+                          pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ")
+                            (a :: al) o#ctyp t2
                     | Ast.TyPrv (_, t) ->
                         pp f "@[private@ %a@]" o#simple_ctyp t
                     | t -> o#simple_ctyp f t
-                  
                 method constructor_type =
                   fun f t ->
                     match t with
@@ -19830,7 +19683,6 @@ module Printers =
                             o#constructor_type t2
                     | Ast.TyArr (_, _, _) -> pp f "(%a)" o#ctyp t
                     | t -> o#ctyp f t
-                  
                 method sig_item =
                   fun f sg ->
                     let () = o#node f sg Ast.loc_of_sig_item
@@ -19887,7 +19739,6 @@ module Printers =
                             o#module_rec_binding mb semisep
                       | Ast.SgDir (_, _, _) -> ()
                       | Ast.SgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep
-                  
                 method str_item =
                   fun f st ->
                     let () = o#node f st Ast.loc_of_str_item
@@ -19954,13 +19805,14 @@ module Printers =
                       | Ast.StDir (_, _, _) -> ()
                       | Ast.StAnt (_, s) -> pp f "%a%(%)" o#anti s semisep
                       | Ast.StExc (_, _, (Ast.OAnt _)) -> assert false
-                  
                 method module_type =
                   fun f mt ->
                     let () = o#node f mt Ast.loc_of_module_type
                     in
                       match mt with
                       | Ast.MtNil _ -> assert false
+                      | Ast.MtOf (_, me) ->
+                          pp f "@[<2>module type of@ %a@]" o#module_expr me
                       | Ast.MtId (_, i) -> o#ident f i
                       | Ast.MtAnt (_, s) -> o#anti f s
                       | Ast.MtFun (_, s, mt1, mt2) ->
@@ -19972,7 +19824,6 @@ module Printers =
                       | Ast.MtWit (_, mt, wc) ->
                           pp f "@[<2>%a@ with@ %a@]" o#module_type mt
                             o#with_constraint wc
-                  
                 method with_constraint =
                   fun f wc ->
                     let () = o#node f wc Ast.loc_of_with_constr
@@ -19994,7 +19845,6 @@ module Printers =
                            pp f o#andsep;
                            o#with_constraint f wc2)
                       | Ast.WcAnt (_, s) -> o#anti f s
-                  
                 method module_expr =
                   fun f me ->
                     let () = o#node f me Ast.loc_of_module_expr
@@ -20007,7 +19857,6 @@ module Printers =
                             "@[<2>@[<hv2>struct@ %a@]@ end :@ @[<hv2>sig@ %a@]@ end@]"
                             o#str_item st o#sig_item sg
                       | _ -> o#simple_module_expr f me
-                  
                 method simple_module_expr =
                   fun f me ->
                     let () = o#node f me Ast.loc_of_module_expr
@@ -20034,7 +19883,6 @@ module Printers =
                             o#module_type mt
                       | Ast.MePkg (_, e) ->
                           pp f "@[<1>(%s %a)@]" o#value_val o#expr e
-                  
                 method class_expr =
                   fun f ce ->
                     let () = o#node f ce Ast.loc_of_class_expr
@@ -20082,7 +19930,6 @@ module Printers =
                           pp f "@[<2>%a =@]@ %a" o#class_expr ce1
                             o#class_expr ce2
                       | _ -> assert false
-                  
                 method class_type =
                   fun f ct ->
                     let () = o#node f ct Ast.loc_of_class_type
@@ -20119,7 +19966,6 @@ module Printers =
                       | Ast.CtEq (_, ct1, ct2) ->
                           pp f "%a =@ %a" o#class_type ct1 o#class_type ct2
                       | _ -> assert false
-                  
                 method class_sig_item =
                   fun f csg ->
                     let () = o#node f csg Ast.loc_of_class_sig_item
@@ -20135,22 +19981,21 @@ module Printers =
                            o#class_sig_item f csg2)
                       | Ast.CgCtr (_, t1, t2) ->
                           pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1
-                            o#ctyp t2 semisep
+                            o#ctyp t2 no_semisep
                       | Ast.CgInh (_, ct) ->
                           pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct
-                            semisep
+                            no_semisep
                       | Ast.CgMth (_, s, pr, t) ->
                           pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag
-                            pr o#var s o#ctyp t semisep
+                            pr o#var s o#ctyp t no_semisep
                       | Ast.CgVir (_, s, pr, t) ->
                           pp f "@[<2>method virtual %a%a :@ %a%(%)@]"
-                            o#private_flag pr o#var s o#ctyp t semisep
+                            o#private_flag pr o#var s o#ctyp t no_semisep
                       | Ast.CgVal (_, s, mu, vi, t) ->
                           pp f "@[<2>%s %a%a%a :@ %a%(%)@]" o#value_val
                             o#mutable_flag mu o#virtual_flag vi o#var s
-                            o#ctyp t semisep
-                      | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s semisep
-                  
+                            o#ctyp t no_semisep
+                      | Ast.CgAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep
                 method class_str_item =
                   fun f cst ->
                     let () = o#node f cst Ast.loc_of_class_str_item
@@ -20166,45 +20011,43 @@ module Printers =
                            o#class_str_item f cst2)
                       | Ast.CrCtr (_, t1, t2) ->
                           pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1
-                            o#ctyp t2 semisep
+                            o#ctyp t2 no_semisep
                       | Ast.CrInh (_, ov, ce, "") ->
                           pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov
-                            o#class_expr ce semisep
+                            o#class_expr ce no_semisep
                       | Ast.CrInh (_, ov, ce, s) ->
                           pp f "@[<2>inherit%a@ %a as@ %a%(%)@]"
                             o#override_flag ov o#class_expr ce o#var s
-                            semisep
+                            no_semisep
                       | Ast.CrIni (_, e) ->
-                          pp f "@[<2>initializer@ %a%(%)@]" o#expr e semisep
+                          pp f "@[<2>initializer@ %a%(%)@]" o#expr e
+                            no_semisep
                       | Ast.CrMth (_, s, ov, pr, e, (Ast.TyNil _)) ->
                           pp f "@[<2>method%a %a%a =@ %a%(%)@]"
                             o#override_flag ov o#private_flag pr o#var s
-                            o#expr e semisep
+                            o#expr e no_semisep
                       | Ast.CrMth (_, s, ov, pr, e, t) ->
                           pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]"
                             o#override_flag ov o#private_flag pr o#var s
-                            o#ctyp t o#expr e semisep
+                            o#ctyp t o#expr e no_semisep
                       | Ast.CrVir (_, s, pr, t) ->
                           pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]"
-                            o#private_flag pr o#var s o#ctyp t semisep
+                            o#private_flag pr o#var s o#ctyp t no_semisep
                       | Ast.CrVvr (_, s, mu, t) ->
                           pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" o#value_val
-                            o#mutable_flag mu o#var s o#ctyp t semisep
+                            o#mutable_flag mu o#var s o#ctyp t no_semisep
                       | Ast.CrVal (_, s, ov, mu, e) ->
                           pp f "@[<2>%s%a %a%a =@ %a%(%)@]" o#value_val
                             o#override_flag ov o#mutable_flag mu o#var s
-                            o#expr e semisep
-                      | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s semisep
-                  
+                            o#expr e no_semisep
+                      | Ast.CrAnt (_, s) -> pp f "%a%(%)" o#anti s no_semisep
                 method implem =
                   fun f st ->
                     match st with
                     | Ast.StExp (_, e) ->
                         pp f "@[<0>%a%(%)@]@." o#expr e semisep
                     | st -> pp f "@[<v0>%a@]@." o#str_item st
-                  
                 method interf = fun f sg -> pp f "@[<v0>%a@]@." o#sig_item sg
-                  
               end
               
             let with_outfile output_file fct arg =
@@ -20316,8 +20159,7 @@ module Printers =
             class printer :
               ?curry_constr: bool ->
                 ?comments: bool ->
-                  unit -> object ('a) inherit OCaml.Make(Syntax).printer
-                                         end
+                  unit -> object ('a) inherit OCaml.Make(Syntax).printer end
               
             val with_outfile :
               string option -> (formatter -> 'a -> unit) -> 'a -> unit
@@ -20369,35 +20211,22 @@ module Printers =
                 inherit
                   PP_o.printer ~curry_constr: init_curry_constr ~comments () as
                   super
-                  
                 val! semisep = (";" : sep)
-                  
+                val! no_semisep = (";" : sep)
                 val mode = if comments then `comments else `no_comments
-                  
                 val curry_constr = init_curry_constr
-                  
                 val first_match_case = true
-                  
                 method andsep : sep = "@]@ @[<2>and@ "
-                  
                 method value_val = "value"
-                  
                 method value_let = "value"
-                  
                 method under_pipe = o
-                  
                 method under_semi = o
-                  
                 method reset_semi = o
-                  
                 method reset = o
-                  
                 method private unset_first_match_case =
                   {< first_match_case = false; >}
-                  
                 method private set_first_match_case =
                   {< first_match_case = true; >}
-                  
                 method seq =
                   fun f e ->
                     let rec self right f e =
@@ -20421,7 +20250,6 @@ module Printers =
                               | _ -> go_right f e2))
                         | e -> o#expr f e
                     in self true f e
-                  
                 method var =
                   fun f ->
                     function
@@ -20441,14 +20269,12 @@ module Printers =
                              failwith
                                (sprintf "Bad token used as an identifier: %s"
                                   (Token.to_string tok)))
-                  
                 method type_params =
                   fun f ->
                     function
                     | [] -> ()
                     | [ x ] -> pp f "@ %a" o#ctyp x
                     | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l
-                  
                 method match_case =
                   fun f ->
                     function
@@ -20456,7 +20282,6 @@ module Printers =
                     | m ->
                         pp f "@ [ %a ]" o#set_first_match_case#match_case_aux
                           m
-                  
                 method match_case_aux =
                   fun f ->
                     function
@@ -20475,13 +20300,11 @@ module Printers =
                         in
                           pp f "@[<2>%a@ when@ %a@ ->@ %a@]" o#patt p
                             o#under_pipe#expr w o#under_pipe#expr e
-                  
                 method sum_type =
                   fun f ->
                     function
                     | Ast.TyNil _ -> pp f "[]"
                     | t -> pp f "@[<hv0>[ %a ]@]" o#ctyp t
-                  
                 method ident =
                   fun f i ->
                     let () = o#node f i Ast.loc_of_ident
@@ -20490,7 +20313,6 @@ module Printers =
                       | Ast.IdApp (_, i1, i2) ->
                           pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2
                       | i -> o#dot_ident f i
-                  
                 method private dot_ident =
                   fun f i ->
                     let () = o#node f i Ast.loc_of_ident
@@ -20501,7 +20323,6 @@ module Printers =
                       | Ast.IdAnt (_, s) -> o#anti f s
                       | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s
                       | i -> pp f "(%a)" o#ident i
-                  
                 method patt4 =
                   fun f ->
                     function
@@ -20519,7 +20340,6 @@ module Printers =
                                pp f "@[<2>[ %a ::@ %a ]@]"
                                  (list o#patt ";@ ") pl o#patt x)
                     | p -> super#patt4 f p
-                  
                 method expr_list_cons =
                   fun _ f e ->
                     let (el, c) = o#mk_expr_list e
@@ -20529,7 +20349,6 @@ module Printers =
                       | Some x ->
                           pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el
                             o#expr x
-                  
                 method expr =
                   fun f e ->
                     let () = o#node f e Ast.loc_of_expr
@@ -20548,7 +20367,6 @@ module Printers =
                           pp f "@[<hv0>fun%a@]" o#match_case a
                       | Ast.ExAsf _ -> pp f "@[<2>assert@ False@]"
                       | e -> super#expr f e
-                  
                 method dot_expr =
                   fun f e ->
                     let () = o#node f e Ast.loc_of_expr
@@ -20558,7 +20376,6 @@ module Printers =
                           (Ast.ExId (_, (Ast.IdLid (_, "val"))))) ->
                           pp f "@[<2>%a.@,val@]" o#simple_expr e
                       | e -> super#dot_expr f e
-                  
                 method ctyp =
                   fun f t ->
                     let () = o#node f t Ast.loc_of_ctyp
@@ -20575,7 +20392,6 @@ module Printers =
                       | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) ->
                           pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2
                       | t -> super#ctyp f t
-                  
                 method simple_ctyp =
                   fun f t ->
                     let () = o#node f t Ast.loc_of_ctyp
@@ -20595,7 +20411,6 @@ module Printers =
                       | Ast.TyLab (_, s, t) ->
                           pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t
                       | t -> super#simple_ctyp f t
-                  
                 method ctyp1 =
                   fun f ->
                     function
@@ -20613,7 +20428,6 @@ module Printers =
                           pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ")
                             (a :: al) o#ctyp t2
                     | t -> super#ctyp1 f t
-                  
                 method constructor_type =
                   fun f t ->
                     match t with
@@ -20623,14 +20437,12 @@ module Printers =
                           pp f "%a@ and %a" o#constructor_type t1
                             o#constructor_type t2
                     | t -> o#ctyp f t
-                  
                 method str_item =
                   fun f st ->
                     match st with
                     | Ast.StExp (_, e) ->
                         pp f "@[<2>%a%(%)@]" o#expr e semisep
                     | st -> super#str_item f st
-                  
                 method module_expr =
                   fun f me ->
                     let () = o#node f me Ast.loc_of_module_expr
@@ -20640,7 +20452,6 @@ module Printers =
                           pp f "@[<2>%a@ %a@]" o#module_expr me1
                             o#simple_module_expr me2
                       | me -> super#module_expr f me
-                  
                 method simple_module_expr =
                   fun f me ->
                     let () = o#node f me Ast.loc_of_module_expr
@@ -20648,9 +20459,7 @@ module Printers =
                       match me with
                       | Ast.MeApp (_, _, _) -> pp f "(%a)" o#module_expr me
                       | _ -> super#simple_module_expr f me
-                  
                 method implem = fun f st -> pp f "@[<v0>%a@]@." o#str_item st
-                  
                 method class_type =
                   fun f ct ->
                     let () = o#node f ct Ast.loc_of_class_type
@@ -20671,7 +20480,6 @@ module Printers =
                           pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i
                             o#class_params t
                       | ct -> super#class_type f ct
-                  
                 method class_expr =
                   fun f ce ->
                     let () = o#node f ce Ast.loc_of_class_expr
@@ -20687,9 +20495,8 @@ module Printers =
                       | Ast.CeCon (_, Ast.ViVirtual, (Ast.IdLid (_, i)), t)
                           ->
                           pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i
-                            o#ctyp t
+                            o#class_params t
                       | ce -> super#class_expr f ce
-                  
               end
               
             let with_outfile = with_outfile
@@ -21418,6 +21225,11 @@ module Register :
       PreCast.Ast.str_item parser_fun ->
         PreCast.Ast.sig_item parser_fun -> unit
       
+    val current_parser :
+      unit ->
+        ((PreCast.Ast.str_item parser_fun) *
+         (PreCast.Ast.sig_item parser_fun))
+      
     module Parser
       (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser(Ast).S) :
       sig  end
@@ -21441,6 +21253,11 @@ module Register :
       PreCast.Ast.str_item printer_fun ->
         PreCast.Ast.sig_item printer_fun -> unit
       
+    val current_printer :
+      unit ->
+        ((PreCast.Ast.str_item printer_fun) *
+         (PreCast.Ast.sig_item printer_fun))
+      
     module Printer
       (Id : Sig.Id)
       (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer(Syn.Ast).S) :
@@ -21526,12 +21343,16 @@ module Register :
       
     let register_parser f g = (str_item_parser := f; sig_item_parser := g)
       
+    let current_parser () = ((!str_item_parser), (!sig_item_parser))
+      
     let register_str_item_printer f = str_item_printer := f
       
     let register_sig_item_printer f = sig_item_printer := f
       
     let register_printer f g = (str_item_printer := f; sig_item_printer := g)
       
+    let current_printer () = ((!str_item_printer), (!sig_item_printer))
+      
     module Plugin
       (Id : Sig.Id) (Maker : functor (Unit : sig  end) -> sig  end) =
       struct

diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml
index 32848f03d24388f9fd1bb9a2d0e5937ac7729002..acb8afd3cba256b17bbd5e6d6adc0c4db3942b51 100644 (file)
--- a/camlp4/boot/Camlp4Ast.ml
+++ b/camlp4/boot/Camlp4Ast.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 (* Authors:
@@ -108,12 +108,12 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
       | Ast.PaLab _ _ p -> is_irrefut_patt p
       | Ast.PaLaz _ p -> is_irrefut_patt p
       | Ast.PaId _ _ -> False
-      | (* here one need to know the arity of constructors *)
-          Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ |
-            Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ |
-            Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ |
-            Ast.PaAnt _ _
-          -> False ];
+      | (* here one need to know the arity of constructors *) Ast.PaMod _ _
+          -> True
+      | Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ |
+          Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ |
+          Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ |
+          Ast.PaAnt _ _ -> False ];
     value rec is_constructor =
       fun
       [ Ast.IdAcc _ _ i -> is_constructor i
@@ -471,10 +471,11 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
             value meta_loc = meta_loc_expr;
             module Expr =
               struct
-                value meta_string _loc s = Ast.ExStr _loc s;
+                value meta_string _loc s =
+                  Ast.ExStr _loc (safe_string_escaped s);
                 value meta_int _loc s = Ast.ExInt _loc s;
                 value meta_float _loc s = Ast.ExFlo _loc s;
-                value meta_char _loc s = Ast.ExChr _loc s;
+                value meta_char _loc s = Ast.ExChr _loc (String.escaped s);
                 value meta_bool _loc =
                   fun
                   [ False -> Ast.ExId _loc (Ast.IdUid _loc "False")
@@ -1042,6 +1043,18 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
                                  (Ast.IdUid _loc "TyVrn")))
                            (meta_loc _loc x0))
                         (meta_string _loc x1)
+                  | Ast.TyAnM x0 ->
+                      Ast.ExApp _loc
+                        (Ast.ExId _loc
+                           (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                              (Ast.IdUid _loc "TyAnM")))
+                        (meta_loc _loc x0)
+                  | Ast.TyAnP x0 ->
+                      Ast.ExApp _loc
+                        (Ast.ExId _loc
+                           (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                              (Ast.IdUid _loc "TyAnP")))
+                        (meta_loc _loc x0)
                   | Ast.TyQuM x0 x1 ->
                       Ast.ExApp _loc
                         (Ast.ExApp _loc
@@ -1066,6 +1079,16 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
                                  (Ast.IdUid _loc "TyQuo")))
                            (meta_loc _loc x0))
                         (meta_string _loc x1)
+                  | Ast.TyTypePol x0 x1 x2 ->
+                      Ast.ExApp _loc
+                        (Ast.ExApp _loc
+                           (Ast.ExApp _loc
+                              (Ast.ExId _loc
+                                 (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                                    (Ast.IdUid _loc "TyTypePol")))
+                              (meta_loc _loc x0))
+                           (meta_ctyp _loc x1))
+                        (meta_ctyp _loc x2)
                   | Ast.TyPol x0 x1 x2 ->
                       Ast.ExApp _loc
                         (Ast.ExApp _loc
@@ -1910,7 +1933,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
                            (Ast.IdUid _loc "OvOverride")) ]
                 and meta_patt _loc =
                   fun
-                  [ Ast.PaLaz x0 x1 ->
+                  [ Ast.PaMod x0 x1 ->
+                      Ast.ExApp _loc
+                        (Ast.ExApp _loc
+                           (Ast.ExId _loc
+                              (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                                 (Ast.IdUid _loc "PaMod")))
+                           (meta_loc _loc x0))
+                        (meta_string _loc x1)
+                  | Ast.PaLaz x0 x1 ->
                       Ast.ExApp _loc
                         (Ast.ExApp _loc
                            (Ast.ExId _loc
@@ -3118,6 +3149,18 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
                                  (Ast.IdUid _loc "TyVrn")))
                            (meta_loc _loc x0))
                         (meta_string _loc x1)
+                  | Ast.TyAnM x0 ->
+                      Ast.PaApp _loc
+                        (Ast.PaId _loc
+                           (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                              (Ast.IdUid _loc "TyAnM")))
+                        (meta_loc _loc x0)
+                  | Ast.TyAnP x0 ->
+                      Ast.PaApp _loc
+                        (Ast.PaId _loc
+                           (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                              (Ast.IdUid _loc "TyAnP")))
+                        (meta_loc _loc x0)
                   | Ast.TyQuM x0 x1 ->
                       Ast.PaApp _loc
                         (Ast.PaApp _loc
@@ -3142,6 +3185,16 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
                                  (Ast.IdUid _loc "TyQuo")))
                            (meta_loc _loc x0))
                         (meta_string _loc x1)
+                  | Ast.TyTypePol x0 x1 x2 ->
+                      Ast.PaApp _loc
+                        (Ast.PaApp _loc
+                           (Ast.PaApp _loc
+                              (Ast.PaId _loc
+                                 (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                                    (Ast.IdUid _loc "TyTypePol")))
+                              (meta_loc _loc x0))
+                           (meta_ctyp _loc x1))
+                        (meta_ctyp _loc x2)
                   | Ast.TyPol x0 x1 x2 ->
                       Ast.PaApp _loc
                         (Ast.PaApp _loc
@@ -3986,7 +4039,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
                            (Ast.IdUid _loc "OvOverride")) ]
                 and meta_patt _loc =
                   fun
-                  [ Ast.PaLaz x0 x1 ->
+                  [ Ast.PaMod x0 x1 ->
+                      Ast.PaApp _loc
+                        (Ast.PaApp _loc
+                           (Ast.PaId _loc
+                              (Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
+                                 (Ast.IdUid _loc "PaMod")))
+                           (meta_loc _loc x0))
+                        (meta_string _loc x1)
+                  | Ast.PaLaz x0 x1 ->
                       Ast.PaApp _loc
                         (Ast.PaApp _loc
                            (Ast.PaId _loc
@@ -4888,7 +4949,10 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
               let _x = o#loc _x in
               let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1
           | PaLaz _x _x_i1 ->
-              let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 ];
+              let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1
+          | PaMod _x _x_i1 ->
+              let _x = o#loc _x in
+              let _x_i1 = o#string _x_i1 in PaMod _x _x_i1 ];
         method override_flag : override_flag -> override_flag =
           fun
           [ OvOverride -> OvOverride
@@ -4971,7 +5035,20 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
               let _x = o#loc _x in
               let _x_i1 = o#string _x_i1 in MbAnt _x _x_i1 ];
         method meta_option :
-          ! 'a 'a_out.
+          ! (****************************************************************************)
+            (*                                                                          *)
+            (*                                   OCaml                                  *)
+            (*                                                                          *)
+            (*                            INRIA Rocquencourt                            *)
+            (*                                                                          *)
+            (*  Copyright  2007   Institut National de Recherche  en  Informatique et   *)
+            (*  en Automatique.  All rights reserved.  This file is distributed under   *)
+            (*  the terms of the GNU Library General Public License, with the special   *)
+            (*  exception on linking described in LICENSE at the top of the OCaml       *)
+            (*  source tree.                                                            *)
+            (*                                                                          *)
+            (****************************************************************************)
+            'a 'a_out.
             ('self_type -> 'a -> 'a_out) ->
               meta_option 'a -> meta_option 'a_out =
           fun _f_a ->
@@ -5242,6 +5319,10 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
               let _x = o#loc _x in
               let _x_i1 = o#ctyp _x_i1 in
               let _x_i2 = o#ctyp _x_i2 in TyPol _x _x_i1 _x_i2
+          | TyTypePol _x _x_i1 _x_i2 ->
+              let _x = o#loc _x in
+              let _x_i1 = o#ctyp _x_i1 in
+              let _x_i2 = o#ctyp _x_i2 in TyTypePol _x _x_i1 _x_i2
           | TyQuo _x _x_i1 ->
               let _x = o#loc _x in
               let _x_i1 = o#string _x_i1 in TyQuo _x _x_i1
@@ -5251,6 +5332,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
           | TyQuM _x _x_i1 ->
               let _x = o#loc _x in
               let _x_i1 = o#string _x_i1 in TyQuM _x _x_i1
+          | TyAnP _x -> let _x = o#loc _x in TyAnP _x
+          | TyAnM _x -> let _x = o#loc _x in TyAnM _x
           | TyVrn _x _x_i1 ->
               let _x = o#loc _x in
               let _x_i1 = o#string _x_i1 in TyVrn _x _x_i1
@@ -5672,7 +5755,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
               let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o
           | PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o
           | PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o
-          | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o ];
+          | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o
+          | PaMod _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ];
         method override_flag : override_flag -> 'self_type =
           fun
           [ OvOverride -> o
@@ -5929,9 +6013,14 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
           | TyPol _x _x_i1 _x_i2 ->
               let o = o#loc _x in
               let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o
+          | TyTypePol _x _x_i1 _x_i2 ->
+              let o = o#loc _x in
+              let o = o#ctyp _x_i1 in let o = o#ctyp _x_i2 in o
           | TyQuo _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o
           | TyQuP _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o
           | TyQuM _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o
+          | TyAnP _x -> let o = o#loc _x in o
+          | TyAnM _x -> let o = o#loc _x in o
           | TyVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o
           | TyRec _x _x_i1 -> let o = o#loc _x in let o = o#ctyp _x_i1 in o
           | TyCol _x _x_i1 _x_i2 ->

diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml
index 786e249c4d4032447fb76de21751a9b3186c6bb1..6cc5466c0ede1daeaa74e64e9670f0d67ba0894f 100644 (file)
--- a/camlp4/boot/camlp4boot.ml
+++ b/camlp4/boot/camlp4boot.ml
@@ -5,15 +5,15 @@ module R =
     (* -*- camlp4r -*- *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -932,6 +932,8 @@ New syntax:\
             grammar_entry_create "string_list"
           and opt_override : 'opt_override Gram.Entry.t =
             grammar_entry_create "opt_override"
+          and unquoted_typevars : 'unquoted_typevars Gram.Entry.t =
+            grammar_entry_create "unquoted_typevars"
           and value_val_opt_override : 'value_val_opt_override Gram.Entry.t =
             grammar_entry_create "value_val_opt_override"
           and method_opt_override : 'method_opt_override Gram.Entry.t =
@@ -939,6 +941,9 @@ New syntax:\
           and module_longident_dot_lparen :
             'module_longident_dot_lparen Gram.Entry.t =
             grammar_entry_create "module_longident_dot_lparen"
+          and optional_type_parameter :
+            'optional_type_parameter Gram.Entry.t =
+            grammar_entry_create "optional_type_parameter"
           and fun_def_cont_no_when : 'fun_def_cont_no_when Gram.Entry.t =
             grammar_entry_create "fun_def_cont_no_when"
           and fun_def_cont : 'fun_def_cont Gram.Entry.t =
@@ -1148,13 +1153,13 @@ New syntax:\
                          ([ Gram.Skeyword "module"; Gram.Skeyword "type";
                             Gram.Snterm
                               (Gram.Entry.obj
-                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                                 (a_ident : 'a_ident Gram.Entry.t));
                             Gram.Skeyword "=";
                             Gram.Snterm
                               (Gram.Entry.obj
                                  (module_type : 'module_type Gram.Entry.t)) ],
                           (Gram.Action.mk
-                             (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _
+                             (fun (mt : 'module_type) _ (i : 'a_ident) _ _
                                 (_loc : Gram.Loc.t) ->
                                 (Ast.StMty (_loc, i, mt) : 'str_item))));
                          ([ Gram.Skeyword "module"; Gram.Skeyword "rec";
@@ -1520,21 +1525,21 @@ New syntax:\
                          ([ Gram.Skeyword "module"; Gram.Skeyword "type";
                             Gram.Snterm
                               (Gram.Entry.obj
-                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
+                                 (a_ident : 'a_ident Gram.Entry.t)) ],
                           (Gram.Action.mk
-                             (fun (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) ->
+                             (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
                                 (Ast.SgMty (_loc, i, (Ast.MtNil _loc)) :
                                   'sig_item))));
                          ([ Gram.Skeyword "module"; Gram.Skeyword "type";
                             Gram.Snterm
                               (Gram.Entry.obj
-                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                                 (a_ident : 'a_ident Gram.Entry.t));
                             Gram.Skeyword "=";
                             Gram.Snterm
                               (Gram.Entry.obj
                                  (module_type : 'module_type Gram.Entry.t)) ],
                           (Gram.Action.mk
-                             (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _
+                             (fun (mt : 'module_type) _ (i : 'a_ident) _ _
                                 (_loc : Gram.Loc.t) ->
                                 (Ast.SgMty (_loc, i, mt) : 'sig_item))));
                          ([ Gram.Skeyword "module"; Gram.Skeyword "rec";
@@ -3677,6 +3682,29 @@ New syntax:\
                           (Gram.Action.mk
                              (fun _ (p : 'patt) _ (_loc : Gram.Loc.t) ->
                                 (p : 'patt))));
+                         ([ Gram.Skeyword "("; Gram.Skeyword "module";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ":";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (package_type : 'package_type Gram.Entry.t));
+                            Gram.Skeyword ")" ],
+                          (Gram.Action.mk
+                             (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _
+                                _ (_loc : Gram.Loc.t) ->
+                                (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
+                                   (Ast.TyPkg (_loc, pt))) :
+                                  'patt))));
+                         ([ Gram.Skeyword "("; Gram.Skeyword "module";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ")" ],
+                          (Gram.Action.mk
+                             (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
+                                -> (Ast.PaMod (_loc, m) : 'patt))));
                          ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
                           (Gram.Action.mk
                              (fun _ _ (_loc : Gram.Loc.t) ->
@@ -4125,6 +4153,29 @@ New syntax:\
                           (Gram.Action.mk
                              (fun _ (p : 'ipatt) _ (_loc : Gram.Loc.t) ->
                                 (p : 'ipatt))));
+                         ([ Gram.Skeyword "("; Gram.Skeyword "module";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ":";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (package_type : 'package_type Gram.Entry.t));
+                            Gram.Skeyword ")" ],
+                          (Gram.Action.mk
+                             (fun _ (pt : 'package_type) _ (m : 'a_UIDENT) _
+                                _ (_loc : Gram.Loc.t) ->
+                                (Ast.PaTyc (_loc, (Ast.PaMod (_loc, m)),
+                                   (Ast.TyPkg (_loc, pt))) :
+                                  'ipatt))));
+                         ([ Gram.Skeyword "("; Gram.Skeyword "module";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ")" ],
+                          (Gram.Action.mk
+                             (fun _ (m : 'a_UIDENT) _ _ (_loc : Gram.Loc.t)
+                                -> (Ast.PaMod (_loc, m) : 'ipatt))));
                          ([ Gram.Skeyword "("; Gram.Skeyword ")" ],
                           (Gram.Action.mk
                              (fun _ _ (_loc : Gram.Loc.t) ->
@@ -4432,10 +4483,10 @@ New syntax:\
                             Gram.Slist0
                               (Gram.Snterm
                                  (Gram.Entry.obj
-                                    (type_parameter :
-                                      'type_parameter Gram.Entry.t))) ],
+                                    (optional_type_parameter :
+                                      'optional_type_parameter Gram.Entry.t))) ],
                           (Gram.Action.mk
-                             (fun (tpl : 'type_parameter list)
+                             (fun (tpl : 'optional_type_parameter list)
                                 (i : 'a_LIDENT) (_loc : Gram.Loc.t) ->
                                 ((i, tpl) : 'type_ident_and_parameters)))) ]) ]))
                   ());
@@ -4540,6 +4591,76 @@ New syntax:\
                                       'type_parameter)
                                 | _ -> assert false))) ]) ]))
                   ());
+             Gram.extend
+               (optional_type_parameter :
+                 'optional_type_parameter Gram.Entry.t)
+               ((fun () ->
+                   (None,
+                    [ (None, None,
+                       [ ([ Gram.Skeyword "_" ],
+                          (Gram.Action.mk
+                             (fun _ (_loc : Gram.Loc.t) ->
+                                (Ast.TyAny _loc : 'optional_type_parameter))));
+                         ([ Gram.Skeyword "-"; Gram.Skeyword "_" ],
+                          (Gram.Action.mk
+                             (fun _ _ (_loc : Gram.Loc.t) ->
+                                (Ast.TyAnM _loc : 'optional_type_parameter))));
+                         ([ Gram.Skeyword "+"; Gram.Skeyword "_" ],
+                          (Gram.Action.mk
+                             (fun _ _ (_loc : Gram.Loc.t) ->
+                                (Ast.TyAnP _loc : 'optional_type_parameter))));
+                         ([ Gram.Skeyword "-"; Gram.Skeyword "'";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_ident : 'a_ident Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
+                                (Ast.TyQuM (_loc, i) :
+                                  'optional_type_parameter))));
+                         ([ Gram.Skeyword "+"; Gram.Skeyword "'";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_ident : 'a_ident Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
+                                (Ast.TyQuP (_loc, i) :
+                                  'optional_type_parameter))));
+                         ([ Gram.Skeyword "'";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_ident : 'a_ident Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (i : 'a_ident) _ (_loc : Gram.Loc.t) ->
+                                (Ast.TyQuo (_loc, i) :
+                                  'optional_type_parameter))));
+                         ([ Gram.Stoken
+                              (((function | QUOTATION _ -> true | _ -> false),
+                                "QUOTATION _")) ],
+                          (Gram.Action.mk
+                             (fun (__camlp4_0 : Gram.Token.t)
+                                (_loc : Gram.Loc.t) ->
+                                match __camlp4_0 with
+                                | QUOTATION x ->
+                                    (Quotation.expand _loc x Quotation.
+                                       DynAst.ctyp_tag :
+                                      'optional_type_parameter)
+                                | _ -> assert false)));
+                         ([ Gram.Stoken
+                              (((function
+                                 | ANTIQUOT (("" | "typ" | "anti"), _) ->
+                                     true
+                                 | _ -> false),
+                                "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ],
+                          (Gram.Action.mk
+                             (fun (__camlp4_0 : Gram.Token.t)
+                                (_loc : Gram.Loc.t) ->
+                                match __camlp4_0 with
+                                | ANTIQUOT ((("" | "typ" | "anti" as n)), s)
+                                    ->
+                                    (Ast.TyAnt (_loc, (mk_anti n s)) :
+                                      'optional_type_parameter)
+                                | _ -> assert false))) ]) ]))
+                  ());
              Gram.extend (ctyp : 'ctyp Gram.Entry.t)
                ((fun () ->
                    (None,
@@ -4911,6 +5032,46 @@ New syntax:\
                              (fun (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
                                 (Ast.TyId (_loc, (Ast.IdUid (_loc, s))) :
                                   'constructor_declarations))));
+                         ([ Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ":";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (constructor_arg_list :
+                                   'constructor_arg_list Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (ret : 'constructor_arg_list) _
+                                (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+                                (match Ast.list_of_ctyp ret [] with
+                                 | [ c ] ->
+                                     Ast.TyCol (_loc,
+                                       (Ast.TyId (_loc,
+                                          (Ast.IdUid (_loc, s)))),
+                                       c)
+                                 | _ ->
+                                     raise
+                                       (Stream.Error
+                                          "invalid generalized constructor type") :
+                                  'constructor_declarations))));
+                         ([ Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_UIDENT : 'a_UIDENT Gram.Entry.t));
+                            Gram.Skeyword ":";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (constructor_arg_list :
+                                   'constructor_arg_list Gram.Entry.t));
+                            Gram.Skeyword "->";
+                            Gram.Snterm
+                              (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (ret : 'ctyp) _ (t : 'constructor_arg_list)
+                                _ (s : 'a_UIDENT) (_loc : Gram.Loc.t) ->
+                                (Ast.TyCol (_loc,
+                                   (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))),
+                                   (Ast.TyArr (_loc, t, ret))) :
+                                  'constructor_declarations))));
                          ([ Gram.Snterm
                               (Gram.Entry.obj
                                  (a_UIDENT : 'a_UIDENT Gram.Entry.t));
@@ -6352,6 +6513,23 @@ New syntax:\
                              (fun (e : 'expr) _ (t : 'poly_type) _
                                 (_loc : Gram.Loc.t) ->
                                 (Ast.ExTyc (_loc, e, t) : 'cvalue_binding))));
+                         ([ Gram.Skeyword ":"; Gram.Skeyword "type";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (unquoted_typevars :
+                                   'unquoted_typevars Gram.Entry.t));
+                            Gram.Skeyword ".";
+                            Gram.Snterm
+                              (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t));
+                            Gram.Skeyword "=";
+                            Gram.Snterm
+                              (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (e : 'expr) _ (t2 : 'ctyp) _
+                                (t1 : 'unquoted_typevars) _ _
+                                (_loc : Gram.Loc.t) ->
+                                (let u = Ast.TyTypePol (_loc, t1, t2)
+                                 in Ast.ExTyc (_loc, e, u) : 'cvalue_binding))));
                          ([ Gram.Skeyword "=";
                             Gram.Snterm
                               (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
@@ -6836,8 +7014,9 @@ New syntax:\
                        [ ([ Gram.Snterm
                               (Gram.Entry.obj (label : 'label Gram.Entry.t));
                             Gram.Skeyword "=";
-                            Gram.Snterm
-                              (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
+                            Gram.Snterml
+                              ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
+                              "top") ],
                           (Gram.Action.mk
                              (fun (e : 'expr) _ (l : 'label)
                                 (_loc : Gram.Loc.t) ->
@@ -7046,6 +7225,52 @@ New syntax:\
                                 (_loc : Gram.Loc.t) ->
                                 (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ]))
                   ());
+             Gram.extend
+               (unquoted_typevars : 'unquoted_typevars Gram.Entry.t)
+               ((fun () ->
+                   (None,
+                    [ (None, (Some Camlp4.Sig.Grammar.LeftA),
+                       [ ([ Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_ident : 'a_ident Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (i : 'a_ident) (_loc : Gram.Loc.t) ->
+                                (Ast.TyId (_loc, (Ast.IdLid (_loc, i))) :
+                                  'unquoted_typevars))));
+                         ([ Gram.Stoken
+                              (((function | QUOTATION _ -> true | _ -> false),
+                                "QUOTATION _")) ],
+                          (Gram.Action.mk
+                             (fun (__camlp4_0 : Gram.Token.t)
+                                (_loc : Gram.Loc.t) ->
+                                match __camlp4_0 with
+                                | QUOTATION x ->
+                                    (Quotation.expand _loc x Quotation.
+                                       DynAst.ctyp_tag :
+                                      'unquoted_typevars)
+                                | _ -> assert false)));
+                         ([ Gram.Stoken
+                              (((function
+                                 | ANTIQUOT (("" | "typ"), _) -> true
+                                 | _ -> false),
+                                "ANTIQUOT ((\"\" | \"typ\"), _)")) ],
+                          (Gram.Action.mk
+                             (fun (__camlp4_0 : Gram.Token.t)
+                                (_loc : Gram.Loc.t) ->
+                                match __camlp4_0 with
+                                | ANTIQUOT ((("" | "typ" as n)), s) ->
+                                    (Ast.TyAnt (_loc,
+                                       (mk_anti ~c: "ctyp" n s)) :
+                                      'unquoted_typevars)
+                                | _ -> assert false)));
+                         ([ Gram.Sself; Gram.Sself ],
+                          (Gram.Action.mk
+                             (fun (t2 : 'unquoted_typevars)
+                                (t1 : 'unquoted_typevars) (_loc : Gram.Loc.t)
+                                ->
+                                (Ast.TyApp (_loc, t1, t2) :
+                                  'unquoted_typevars)))) ]) ]))
+                  ());
              Gram.extend (row_field : 'row_field Gram.Entry.t)
                ((fun () ->
                    (None,
@@ -8492,10 +8717,9 @@ New syntax:\
                              (fun (x : 'type_parameter) (_loc : Gram.Loc.t)
                                 -> (x : 'more_ctyp))));
                          ([ Gram.Snterm
-                              (Gram.Entry.obj
-                                 (type_kind : 'type_kind Gram.Entry.t)) ],
+                              (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
                           (Gram.Action.mk
-                             (fun (x : 'type_kind) (_loc : Gram.Loc.t) ->
+                             (fun (x : 'ctyp) (_loc : Gram.Loc.t) ->
                                 (x : 'more_ctyp))));
                          ([ Gram.Skeyword "`";
                             Gram.Snterm
@@ -9183,15 +9407,15 @@ module Camlp4QuotationCommon =
     (* -*- camlp4r -*- *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -9255,7 +9479,6 @@ module Camlp4QuotationCommon =
         let antiquot_expander =
           object
             inherit Ast.map as super
-              
             method patt =
               function
               | (Ast.PaAnt (_loc, s) | Ast.PaStr (_loc, s) as p) ->
@@ -9420,7 +9643,6 @@ module Camlp4QuotationCommon =
                                p)
                          | _ -> p)
               | p -> super#patt p
-              
             method expr =
               function
               | (Ast.ExAnt (_loc, s) | Ast.ExStr (_loc, s) as e) ->
@@ -9461,9 +9683,9 @@ module Camlp4QuotationCommon =
                                (Ast.ExId (_loc,
                                   (Ast.IdAcc (_loc,
                                      (Ast.IdUid (_loc, "Camlp4_import")),
-                                        (Ast.IdAcc (_loc,
-                                           (Ast.IdUid (_loc, "Oprint")),
-                                           (Ast.IdLid (_loc, "float_repres")))))))),
+                                     (Ast.IdAcc (_loc,
+                                        (Ast.IdUid (_loc, "Oprint")),
+                                        (Ast.IdLid (_loc, "float_repres")))))))),
                                e)
                          | "`str" ->
                              Ast.ExApp (_loc,
@@ -9820,7 +10042,6 @@ module Camlp4QuotationCommon =
                                e)
                          | _ -> e)
               | e -> super#expr e
-              
           end
           
         let add_quotation name entry mexpr mpatt =
@@ -9981,15 +10202,15 @@ module Q =
     (* -*- camlp4r -*- *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -10023,15 +10244,15 @@ module Rp =
     (* -*- camlp4r -*- *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright 1998-2006 Institut National de Recherche en Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -10966,15 +11187,15 @@ module G =
     (* -*- camlp4r -*- *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright 2002-2006 Institut National de Recherche en Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -11813,12 +12034,10 @@ module G =
           
         class subst gmod =
           object inherit Ast.map as super
-                   
             method ident =
               function
               | Ast.IdUid (_, x) when x = gm -> gmod
               | x -> super#ident x
-              
           end
           
         let subst_gmod ast gmod = (new subst gmod)#expr ast
@@ -11872,13 +12091,11 @@ module G =
         let wildcarder =
           object (self)
             inherit Ast.map as super
-              
             method patt =
               function
               | Ast.PaId (_loc, (Ast.IdLid (_, _))) -> Ast.PaAny _loc
               | Ast.PaAli (_, p, _) -> self#patt p
               | p -> super#patt p
-              
           end
           
         let mk_tok _loc p t =
@@ -13425,15 +13642,15 @@ module M =
     (* -*- camlp4r -*- *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -13566,14 +13783,11 @@ Added statements:
           in loop
           
         class reloc _loc =
-          object inherit Ast.map as super
-                    method loc = fun _ -> _loc
-                       end
+          object inherit Ast.map as super method loc = fun _ -> _loc end
           
         (* method _Loc_t _ = _loc; *)
         class subst _loc env =
           object inherit reloc _loc as super
-                   
             method expr =
               function
               | (Ast.ExId (_, (Ast.IdLid (_, x))) |
@@ -13581,7 +13795,6 @@ Added statements:
                  as e) ->
                   (try List.assoc x env with | Not_found -> super#expr e)
               | e -> super#expr e
-              
             method patt =
               function
               | (Ast.PaId (_, (Ast.IdLid (_, x))) |
@@ -13590,7 +13803,6 @@ Added statements:
                   (try substp _loc [] (List.assoc x env)
                    with | Not_found -> super#patt p)
               | p -> super#patt p
-              
           end
           
         let incorrect_number loc l1 l2 =
@@ -14448,6 +14660,112 @@ Added statements:
                              (fun (i : Gram.Token.t) (_loc : Gram.Loc.t) ->
                                 (let i = Gram.Token.extract_string i in i :
                                   'uident)))) ]) ]))
+                  ());
+             Gram.extend
+               (* dirty hack to allow polymorphic variants using the introduced keywords. *)
+               (expr : 'expr Gram.Entry.t)
+               ((fun () ->
+                   ((Some (Camlp4.Sig.Grammar.Before "simple")),
+                    [ (None, None,
+                       [ ([ Gram.Skeyword "`";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_ident : 'a_ident Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) ->
+                                (Ast.ExVrn (_loc, s) : 'expr))));
+                         ([ Gram.Skeyword "`";
+                            Gram.srules expr
+                              [ ([ Gram.Skeyword "IN" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__30))));
+                                ([ Gram.Skeyword "DEFINE" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__30))));
+                                ([ Gram.Skeyword "ENDIF" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__30))));
+                                ([ Gram.Skeyword "END" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__30))));
+                                ([ Gram.Skeyword "ELSE" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__30))));
+                                ([ Gram.Skeyword "THEN" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__30))));
+                                ([ Gram.Skeyword "IFNDEF" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__30))));
+                                ([ Gram.Skeyword "IFDEF" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__30)))) ] ],
+                          (Gram.Action.mk
+                             (fun (kwd : 'e__30) _ (_loc : Gram.Loc.t) ->
+                                (Ast.ExVrn (_loc, kwd) : 'expr)))) ]) ]))
+                  ());
+             Gram.extend (* idem *) (patt : 'patt Gram.Entry.t)
+               ((fun () ->
+                   ((Some (Camlp4.Sig.Grammar.Before "simple")),
+                    [ (None, None,
+                       [ ([ Gram.Skeyword "`";
+                            Gram.Snterm
+                              (Gram.Entry.obj
+                                 (a_ident : 'a_ident Gram.Entry.t)) ],
+                          (Gram.Action.mk
+                             (fun (s : 'a_ident) _ (_loc : Gram.Loc.t) ->
+                                (Ast.PaVrn (_loc, s) : 'patt))));
+                         ([ Gram.Skeyword "`";
+                            Gram.srules patt
+                              [ ([ Gram.Skeyword "ENDIF" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__31))));
+                                ([ Gram.Skeyword "END" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__31))));
+                                ([ Gram.Skeyword "ELSE" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__31))));
+                                ([ Gram.Skeyword "THEN" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__31))));
+                                ([ Gram.Skeyword "IFNDEF" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__31))));
+                                ([ Gram.Skeyword "IFDEF" ],
+                                 (Gram.Action.mk
+                                    (fun (x : Gram.Token.t)
+                                       (_loc : Gram.Loc.t) ->
+                                       (Gram.Token.extract_string x : 'e__31)))) ] ],
+                          (Gram.Action.mk
+                             (fun (kwd : 'e__31) _ (_loc : Gram.Loc.t) ->
+                                (Ast.PaVrn (_loc, kwd) : 'patt)))) ]) ]))
                   ()))
           
         let _ =
@@ -14497,15 +14815,15 @@ module D =
     (* -*- camlp4r -*- *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -14690,15 +15008,15 @@ module L =
     (* -*- camlp4r -*- *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -14989,12 +15307,12 @@ module L =
                                       Gram.Skeyword "<-" ],
                                     (Gram.Action.mk
                                        (fun _ (p : 'patt) (_loc : Gram.Loc.t)
-                                          -> (p : 'e__30)))) ]);
+                                          -> (p : 'e__32)))) ]);
                             Gram.Snterml
                               ((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
                               "top") ],
                           (Gram.Action.mk
-                             (fun (e : 'expr) (p : 'e__30)
+                             (fun (e : 'expr) (p : 'e__32)
                                 (_loc : Gram.Loc.t) ->
                                 (`gen ((p, e)) : 'item)))) ]) ]))
                   ()))
@@ -15064,15 +15382,15 @@ module P =
   struct
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -15087,15 +15405,15 @@ module B =
     (* camlp4r *)
     (****************************************************************************)
     (*                                                                          *)
-    (*                              Objective Caml                              *)
+    (*                                   OCaml                                  *)
     (*                                                                          *)
     (*                            INRIA Rocquencourt                            *)
     (*                                                                          *)
     (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
     (*  en Automatique.  All rights reserved.  This file is distributed under   *)
     (*  the terms of the GNU Library General Public License, with the special   *)
-    (*  exception on linking described in LICENSE at the top of the Objective   *)
-    (*  Caml source tree.                                                       *)
+    (*  exception on linking described in LICENSE at the top of the OCaml       *)
+    (*  source tree.                                                            *)
     (*                                                                          *)
     (****************************************************************************)
     (* Authors:
@@ -15184,7 +15502,7 @@ module B =
           | (("Parsers" | ""),
              ("pa_rp.cmo" | "rp" | "rparser" |
                 "camlp4ocamlrevisedparserparser.cmo"))
-              -> load [ pa_r; pa_o; pa_rp ]
+              -> load [ pa_r; pa_rp ]
           | (("Parsers" | ""),
              ("pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo"))
               -> load [ pa_r; pa_o; pa_rp; pa_op ]
@@ -15208,7 +15526,7 @@ module B =
               load [ pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m ]
           | (("Parsers" | ""), "of") ->
               load
-                [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_l; pa_m ]
+                [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m ]
           | (("Parsers" | ""), ("comp" | "camlp4listcomprehension.cmo")) ->
               load [ pa_l ]
           | (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) ->

diff --git a/camlp4/build/.cvsignore b/camlp4/build/.cvsignore
deleted file mode 100644 (file)
index 81edfb4..0000000
--- a/camlp4/build/.cvsignore
+++ /dev/null
@@ -1,7 +0,0 @@
-camlp4_config.ml
-linenum.mli
-linenum.mll
-location.ml
-location.mli
-terminfo.ml
-terminfo.mli

diff --git a/camlp4/build/.ignore b/camlp4/build/.ignore
new file mode 100644 (file)
index 0000000..5332d60
--- /dev/null
+++ b/camlp4/build/.ignore
@@ -0,0 +1,5 @@
+camlp4_config.ml
+location.ml
+location.mli
+terminfo.ml
+terminfo.mli

diff --git a/camlp4/camlp4prof.ml b/camlp4/camlp4prof.ml
index 7e9df17f71a21bf5b14c82c24dc936b7f70ba549..ec2ba8c5add8a7f11d6d4bea9c0c753d287fc048 100644 (file)
--- a/camlp4/camlp4prof.ml
+++ b/camlp4/camlp4prof.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 module Debug = struct value mode _ = False; end;
 
 value count =

diff --git a/camlp4/camlp4prof.mli b/camlp4/camlp4prof.mli
index 0703ac03ce135e836bfc66cfd3f7f4959781d9e1..b7de6450d67013a643bae2cba20900c6e884e5b4 100644 (file)
--- a/camlp4/camlp4prof.mli
+++ b/camlp4/camlp4prof.mli
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007   Institut National de Recherche  en  Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 value count : string -> unit;
 
 value load : in_channel -> list (string * int);

diff --git a/camlp4/examples/_tags b/camlp4/examples/_tags
index 19b2d7017cda0d35ba3476b692b6e5ad9f17180a..296772b8df2b3e3eda49f3b93793e55f91669b70 100644 (file)
--- a/camlp4/examples/_tags
+++ b/camlp4/examples/_tags
@@ -1,3 +1,16 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
 true: warn_A, warn_e
 <{apply_operator,type_quotation,global_handler,expression_closure{,_filter}}.ml> or <free_vars_test.*>: camlp4rf, use_camlp4
 "lambda_quot.ml": camlp4rf, use_camlp4_full

diff --git a/camlp4/examples/apply_operator.ml b/camlp4/examples/apply_operator.ml
index 35b17e5419fd0f9016aaaf1d93716dbc3a3e5e5d..9afbf481b2ee2102bbe912db13b848aed9946ad0 100644 (file)
--- a/camlp4/examples/apply_operator.ml
+++ b/camlp4/examples/apply_operator.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;
 AstFilters.register_str_item_filter
   (Ast.map_expr

diff --git a/camlp4/examples/apply_operator_test.ml b/camlp4/examples/apply_operator_test.ml
index 07ca329f67a669a1d724d836e8865fe5a035a871..94e7355cfebc634bbc22715e849c78e8aaa80699 100644 (file)
--- a/camlp4/examples/apply_operator_test.ml
+++ b/camlp4/examples/apply_operator_test.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 let ( & ) = ();; (* To force it to be inlined. If not it's not well typed. *)
 
 fun f g h x -> f& g& h x

diff --git a/camlp4/examples/arith.ml b/camlp4/examples/arith.ml
index ff7ab4f0de9f3084f021c9a1a997b298f9df003f..e60c7fb59af463018f1dd01a8e59635844fc4580 100644 (file)
--- a/camlp4/examples/arith.ml
+++ b/camlp4/examples/arith.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (* Please keep me in sync with brion.inria.fr/gallium/index.php/Arithmetic_Example *)
 
   open Camlp4.PreCast;;

diff --git a/camlp4/examples/debug_extension.ml b/camlp4/examples/debug_extension.ml
index 21696e4a99d98a4517387f94f837b8bf5b75afb0..a690044ef66954a4b5ffe1edc618d60c049b6fac 100644 (file)
--- a/camlp4/examples/debug_extension.ml
+++ b/camlp4/examples/debug_extension.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (*
  * No debugging code at all:
  *   $ camlp4o -parser Camlp4DebugParser debug_extension.ml

diff --git a/camlp4/examples/ex_str.ml b/camlp4/examples/ex_str.ml
index ac9513b9a0bc5c17827e50bf14927f0be8f776c4..744cc33c8093b884003ea435a9a28b96a50bc4a7 100644 (file)
--- a/camlp4/examples/ex_str.ml
+++ b/camlp4/examples/ex_str.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;;
 module Caml =
   Camlp4OCamlParser.Make

diff --git a/camlp4/examples/ex_str_test.ml b/camlp4/examples/ex_str_test.ml
index 49a696fd207ebcc4ebdd7377f1b2ee29ead4fa3a..7349c5833974f15982b4ec709c38a9889ee9d277 100644 (file)
--- a/camlp4/examples/ex_str_test.ml
+++ b/camlp4/examples/ex_str_test.ml
@@ -1 +1,15 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 function <<foo>> -> <<bar>>

diff --git a/camlp4/examples/expression_closure.ml b/camlp4/examples/expression_closure.ml
index cfc47454d1e452cb74975ead1ebd32bbbf7ede91..300d971086ecacf9214e6a53f665af407adaac99 100644 (file)
--- a/camlp4/examples/expression_closure.ml
+++ b/camlp4/examples/expression_closure.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2006  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 #default_quotation "expr";
 
 open Camlp4.PreCast;

diff --git a/camlp4/examples/expression_closure_filter.ml b/camlp4/examples/expression_closure_filter.ml
index fb1fbe070ee9ad863cf7841c6774408c4e6f4a40..dec08b622d3d74ae6cc97d2d794452e81240b57e 100644 (file)
--- a/camlp4/examples/expression_closure_filter.ml
+++ b/camlp4/examples/expression_closure_filter.ml
@@ -1,4 +1,18 @@
 (* camlp4r *)
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2006  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 #default_quotation "expr";
 
 open Camlp4.PreCast;

diff --git a/camlp4/examples/expression_closure_test.ml b/camlp4/examples/expression_closure_test.ml
index 28747ce0152cdea044b4bbba5494ccb007d2104c..9e4cc536a1cd152972d37d048e6839489b282efd 100644 (file)
--- a/camlp4/examples/expression_closure_test.ml
+++ b/camlp4/examples/expression_closure_test.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (* x and y are free *)
 close_expr(x y);;
 

diff --git a/camlp4/examples/fancy_lambda_quot.ml b/camlp4/examples/fancy_lambda_quot.ml
index be21fa2fd2aa3899cc0e084471b0dcc2974dbb12..8384dd1988e9d1d95da71103c0332e93d2e0c94f 100644 (file)
--- a/camlp4/examples/fancy_lambda_quot.ml
+++ b/camlp4/examples/fancy_lambda_quot.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2008  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (* module LambdaSyntax = struct
   module Loc = Camlp4.PreCast.Loc
   type 'a antiquotable =

diff --git a/camlp4/examples/fancy_lambda_quot_test.ml b/camlp4/examples/fancy_lambda_quot_test.ml
index 5ff348c9dcd1e69f43ac2b34bd03f26c9789ad5d..9f74deea6cb0548d17b49bc3a81d94dcb95eddd3 100644 (file)
--- a/camlp4/examples/fancy_lambda_quot_test.ml
+++ b/camlp4/examples/fancy_lambda_quot_test.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2008  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Fancy_lambda_quot.LambdaSyntax;;
 let _loc = Camlp4.PreCast.Loc.ghost;;
 let rec propagate = function

diff --git a/camlp4/examples/free_vars_test.ml b/camlp4/examples/free_vars_test.ml
index be01edc1529b05a799190543c0216d95196d5f03..84d608b40be00999ffb4406c850f902b259a4b66 100644 (file)
--- a/camlp4/examples/free_vars_test.ml
+++ b/camlp4/examples/free_vars_test.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2006  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Format;
 open Camlp4.PreCast;
 

diff --git a/camlp4/examples/gen_match_case.ml b/camlp4/examples/gen_match_case.ml
index c72a1462307b6031c4a469f0fcd5ee56239e579a..cd402d4cff7fe70654d087b56169c16f6888783a 100644 (file)
--- a/camlp4/examples/gen_match_case.ml
+++ b/camlp4/examples/gen_match_case.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;;
 
 let gen patts exprs =

diff --git a/camlp4/examples/gen_type_N.ml b/camlp4/examples/gen_type_N.ml
index 276f682b3e4a6a6416d8f6c28b4fa0e28ac7f9e8..361f74737c4cd30c6e2c54aee0e7f37028f1416e 100644 (file)
--- a/camlp4/examples/gen_type_N.ml
+++ b/camlp4/examples/gen_type_N.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;;
 
 let data_constructor_arguments _loc n t =

diff --git a/camlp4/examples/gettext_test.ml b/camlp4/examples/gettext_test.ml
index 27f6ceed2b27cdd52ca8a63923c0f1744a5420db..11d1f146e1eff6fcc93953ba4505bd261d5c32f7 100644 (file)
--- a/camlp4/examples/gettext_test.ml
+++ b/camlp4/examples/gettext_test.ml
@@ -1 +1,15 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2008  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 f "test", f "foo", "bar"

diff --git a/camlp4/examples/global_handler.ml b/camlp4/examples/global_handler.ml
index e2da52873d220d569cb96dee068a16e2b30b111c..08957fb808a640f8a89dc96295702a9696d40b37 100644 (file)
--- a/camlp4/examples/global_handler.ml
+++ b/camlp4/examples/global_handler.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2006  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;
 
 value ghost = Loc.ghost;

diff --git a/camlp4/examples/global_handler_test.ml b/camlp4/examples/global_handler_test.ml
index 882af494327d6e90b5896a2c682ed7f1a81d516c..9c3e98ca2106c9d4488e7570bfe4153e7bed1756 100644 (file)
--- a/camlp4/examples/global_handler_test.ml
+++ b/camlp4/examples/global_handler_test.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2006  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Format;;
 let f1 x = printf "f1 %d@." x;;
 let f2 x = printf "f2 %f@." x;;

diff --git a/camlp4/examples/lambda_parser.ml b/camlp4/examples/lambda_parser.ml
index 9c709767909ffd115503c9729f925870704f8d3f..82ab3b8b59ee642a3e36a254062bb58c9da75a0b 100644 (file)
--- a/camlp4/examples/lambda_parser.ml
+++ b/camlp4/examples/lambda_parser.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2008  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *)
 
 type term =

diff --git a/camlp4/examples/lambda_quot.ml b/camlp4/examples/lambda_quot.ml
index 654511af2d999e8cfc030f48b4c14f4e1273b813..cf6485ab336897bacaea279cad824d6abb5f3339 100644 (file)
--- a/camlp4/examples/lambda_quot.ml
+++ b/camlp4/examples/lambda_quot.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;
 module CamlSyntax = Camlp4OCamlParser.Make (Camlp4OCamlRevisedParser.Make Syntax);
 

diff --git a/camlp4/examples/lambda_quot_expr.ml b/camlp4/examples/lambda_quot_expr.ml
index 98922123ad479df0f88170ab4d6875bd6c5017b3..d3eb22fe11545ff9faee3f339cb6380641c62795 100644 (file)
--- a/camlp4/examples/lambda_quot_expr.ml
+++ b/camlp4/examples/lambda_quot_expr.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *)
 
 open Camlp4.PreCast;;

diff --git a/camlp4/examples/lambda_quot_patt.ml b/camlp4/examples/lambda_quot_patt.ml
index e6732dd3a36cb0d9414d02db2c1d5a7c73529947..044007b53b5ee3c02dbd2635dc3d374ec6c26940 100644 (file)
--- a/camlp4/examples/lambda_quot_patt.ml
+++ b/camlp4/examples/lambda_quot_patt.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2008  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *)
 
 open Camlp4.PreCast;;

diff --git a/camlp4/examples/lambda_test.ml b/camlp4/examples/lambda_test.ml
index e2603259a15ae9350f62c5487e13cbff1b079c2c..f56451fc0a8645f6fc2189fa2a0b38909bd0a406 100644 (file)
--- a/camlp4/examples/lambda_test.ml
+++ b/camlp4/examples/lambda_test.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 let id = << fun x -> x >>
 (* Imported and traduced from CCT *)
 let zero = << fun s -> fun z -> z >>

diff --git a/camlp4/examples/macros.ml b/camlp4/examples/macros.ml
index fe7b7392ec8f79fd0e8af1d2dccb2f8c7c1c707a..3ad5687f570d3ac918ebba40eba5e07c2718d5bf 100644 (file)
--- a/camlp4/examples/macros.ml
+++ b/camlp4/examples/macros.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;;
 let foldr_funs = ref [];;
 let foldl_funs = ref [];;

diff --git a/camlp4/examples/parse_files.ml b/camlp4/examples/parse_files.ml
index 0df49c18bc7a573af13a3c386534eea15e17e483..46cf8420b05d03bec8a88b43e373f409c11c5e0b 100644 (file)
--- a/camlp4/examples/parse_files.ml
+++ b/camlp4/examples/parse_files.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;;
 
 module Caml =

diff --git a/camlp4/examples/syb_fold.ml b/camlp4/examples/syb_fold.ml
index 3441c6b61c4d1fe0b986b44ea29f4b9573c3f989..f5abc698fe016fc7799391ca7fc57126949075a1 100644 (file)
--- a/camlp4/examples/syb_fold.ml
+++ b/camlp4/examples/syb_fold.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 type variable = string
  and term =
   | Var   of variable

diff --git a/camlp4/examples/syb_map.ml b/camlp4/examples/syb_map.ml
index 8ef923f325e276b2dcf36616f0df1a91177e6ee3..918563051938869c6891364c6248fda98592799d 100644 (file)
--- a/camlp4/examples/syb_map.ml
+++ b/camlp4/examples/syb_map.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 type variable = string
  and term =
   | Var   of variable

diff --git a/camlp4/examples/test_macros.ml b/camlp4/examples/test_macros.ml
index 1e1b172b5d012d015101e350fd6c2fab2e948f81..955a7c2127ca1b986dbe848d1239f3633a3e0fc9 100644 (file)
--- a/camlp4/examples/test_macros.ml
+++ b/camlp4/examples/test_macros.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 (* DEFINE F(x, y, z) = x + y * z;; *)
 (* F(F(1, 2, 3), 4, 5);; *)
 

diff --git a/camlp4/examples/test_type_quotation.ml b/camlp4/examples/test_type_quotation.ml
index 772dfcfcad7b1e1cdd0b41cba59d0d4574afa825..088924c8f1add04ff488f12e7b8942a12448f632 100644 (file)
--- a/camlp4/examples/test_type_quotation.ml
+++ b/camlp4/examples/test_type_quotation.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 type t1 = <:power< 6 | int >>
 type t2 = <:power< 3 | int -> int >> -> int
 type t3 = <:power< 3 | int -> <:power< 2 | int >> >> -> int

diff --git a/camlp4/examples/type_quotation.ml b/camlp4/examples/type_quotation.ml
index 5dae046fd041efa5706ad61efa17aac6139c2978..5c569a94ac6c1802671fd280b0bc47ffdd0f9fbf 100644 (file)
--- a/camlp4/examples/type_quotation.ml
+++ b/camlp4/examples/type_quotation.ml
@@ -1,3 +1,17 @@
+(****************************************************************************)
+(*                                                                          *)
+(*                                   OCaml                                  *)
+(*                                                                          *)
+(*                            INRIA Rocquencourt                            *)
+(*                                                                          *)
+(*  Copyright  2007  Institut  National  de  Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed under   *)
+(*  the terms of the GNU Library General Public License, with the special   *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
+(*                                                                          *)
+(****************************************************************************)
+
 open Camlp4.PreCast;
 
 value rec mk_tuple _loc t n =

diff --git a/camlp4/man/.cvsignore b/camlp4/man/.cvsignore
deleted file mode 100644 (file)
index 2dc933c..0000000
--- a/camlp4/man/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-camlp4.1
-camlp4.help

diff --git a/camlp4/man/.ignore b/camlp4/man/.ignore
new file mode 100644 (file)
index 0000000..2dc933c
--- /dev/null
+++ b/camlp4/man/.ignore
@@ -0,0 +1,2 @@
+camlp4.1
+camlp4.help

diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile
index 381bdcc53b303461638a6e7caefc825428ea8b46..64b3f970e88e41fa54b53b0c37762a668b0f68f1 100644 (file)
--- a/camlp4/man/Makefile
+++ b/camlp4/man/Makefile
@@ -1,4 +1,15 @@
-
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#      Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt         #
+#                                                                       #
+#   Copyright 2001 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
 
 include ../config/Makefile.cnf
 

diff --git a/camlp4/man/camlp4.1.tpl b/camlp4/man/camlp4.1.tpl
index ff8c65047631e770edddcbc9570963a62df736a3..664ca9f758d69ad85fffccaefc994f7a340e1b4b 100644 (file)
--- a/camlp4/man/camlp4.1.tpl
+++ b/camlp4/man/camlp4.1.tpl
@@ -1,3 +1,18 @@
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *
+.\"*                                                                     *
+.\"*  Copyright 2001 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the GNU Library General Public License, with    *
+.\"*  the special exception on linking described in file ../LICENSE.     *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH CAMLP4 1  "" "INRIA"
 .SH NAME
 camlp4 - Pre-Precessor-Pretty-Printer for OCaml

diff --git a/camlp4/mkcamlp4.ml b/camlp4/mkcamlp4.ml
index 8c911b12d78dafd5a75d5aae2ad6ba96b135f28a..180b17effff0feb02826fdaf6dd1a8bbc6e3a7b9 100644 (file)
--- a/camlp4/mkcamlp4.ml
+++ b/camlp4/mkcamlp4.ml
@@ -1,14 +1,14 @@
 (****************************************************************************)
 (*                                                                          *)
-(*                              Objective Caml                              *)
+(*                                   OCaml                                  *)
 (*                                                                          *)
 (*                            INRIA Rocquencourt                            *)
 (*                                                                          *)
 (*  Copyright  2006   Institut National de Recherche  en  Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed under   *)
 (*  the terms of the GNU Library General Public License, with the special   *)
-(*  exception on linking described in LICENSE at the top of the Objective   *)
-(*  Caml source tree.                                                       *)
+(*  exception on linking described in LICENSE at the top of the OCaml       *)
+(*  source tree.                                                            *)
 (*                                                                          *)
 (****************************************************************************)
 

diff --git a/camlp4/unmaintained/Makefile b/camlp4/unmaintained/Makefile
index b6db0753cb8bc31b288fe77a4e5c147eecab27be..ff79e3367f8ec97c3106aa60cd970af1186e1a4f 100644 (file)
--- a/camlp4/unmaintained/Makefile
+++ b/camlp4/unmaintained/Makefile
@@ -1,12 +1,13 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #                                Camlp4                                 #
 #                                                                       #
 #   Copyright 2004 Institut National de Recherche en Informatique et    #
 #   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../LICENSE.   #
 #                                                                       #
 #########################################################################
 #

diff --git a/camlp4/unmaintained/compile/.cvsignore b/camlp4/unmaintained/compile/.cvsignore
deleted file mode 100644 (file)
index 47817cc..0000000
--- a/camlp4/unmaintained/compile/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-*.fast
-*.fast.opt
-o_fast.ml
-pa_o_fast.ml

diff --git a/camlp4/unmaintained/compile/.ignore b/camlp4/unmaintained/compile/.ignore
new file mode 100644 (file)
index 0000000..47817cc
--- /dev/null
+++ b/camlp4/unmaintained/compile/.ignore
@@ -0,0 +1,4 @@
+*.fast
+*.fast.opt
+o_fast.ml
+pa_o_fast.ml

diff --git a/camlp4/unmaintained/etc/.cvsignore b/camlp4/unmaintained/etc/.cvsignore
deleted file mode 100644 (file)
index 50d8a8e..0000000
--- a/camlp4/unmaintained/etc/.cvsignore
+++ /dev/null
@@ -1,7 +0,0 @@
-*.cm[oia]
-camlp4o
-camlp4sch
-camlp4o.opt
-version.sh
-mkcamlp4.sh
-mkcamlp4.mpw

diff --git a/camlp4/unmaintained/etc/.ignore b/camlp4/unmaintained/etc/.ignore
new file mode 100644 (file)
index 0000000..709f85c
--- /dev/null
+++ b/camlp4/unmaintained/etc/.ignore
@@ -0,0 +1,5 @@
+camlp4o
+camlp4sch
+camlp4o.opt
+version.sh
+mkcamlp4.sh

diff --git a/camlp4/unmaintained/etc/pa_oop.ml b/camlp4/unmaintained/etc/pa_oop.ml
index bb5684ba4e1ac6d4dbefa250617673388d643557..62302e3960ad74b84642597f3ac6ab10faf196ba 100644 (file)
--- a/camlp4/unmaintained/etc/pa_oop.ml
+++ b/camlp4/unmaintained/etc/pa_oop.ml
@@ -107,7 +107,7 @@ value rec cstream gloc =
       <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ]
 ;
 
-(* Syntax extensions in Ocaml grammar *)
+(* Syntax extensions in OCaml grammar *)
 
 
 EXTEND

diff --git a/camlp4/unmaintained/extfold/README b/camlp4/unmaintained/extfold/README
index 2a09ff09880841128a99174c86fe18d2b6500d27..dce3da112c45dbd6ba41ad7e1dec1c838cfd7fc3 100644 (file)
--- a/camlp4/unmaintained/extfold/README
+++ b/camlp4/unmaintained/extfold/README
@@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing
 this package further and/or actively maintain it, please let us know
 (caml@inria.fr)
 
-This package is distributed under the same license as the Objective
-Caml Library (that is, LGPL with a special exception allowing both
+This package is distributed under the same license as the OCaml
+Library (that is, LGPL with a special exception allowing both
 static and dynamic link).
 
 -- Michel Mauny

diff --git a/camlp4/unmaintained/format/Makefile b/camlp4/unmaintained/format/Makefile
index c388720974040de652e4c4ff62d54313e86fccf2..1211a799954155b7cad300a16547fb8274986d06 100644 (file)
--- a/camlp4/unmaintained/format/Makefile
+++ b/camlp4/unmaintained/format/Makefile
@@ -1,12 +1,13 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #                                Camlp4                                 #
 #                                                                       #
 #   Copyright 2004 Institut National de Recherche en Informatique et    #
 #   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../../LICENSE.#
 #                                                                       #
 #########################################################################
 #

diff --git a/camlp4/unmaintained/format/README b/camlp4/unmaintained/format/README
index 809d42f2a8619a6d817c666831ae9f0e3a35e7ce..830402b65179b68c4115239ad2af1dac6c45cace 100644 (file)
--- a/camlp4/unmaintained/format/README
+++ b/camlp4/unmaintained/format/README
@@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing
 this package further and/or actively maintain it, please let us know
 (caml@inria.fr)
 
-This package is distributed under the same license as the Objective
-Caml Library (that is, LGPL with a special exception allowing both
+This package is distributed under the same license as the OCaml
+Library (that is, LGPL with a special exception allowing both
 static and dynamic link).
 
 -- Michel Mauny

diff --git a/camlp4/unmaintained/lefteval/Makefile b/camlp4/unmaintained/lefteval/Makefile
index 7e5cdd02e6e1b46d52f84c1d8d87c9d590c87045..5d47776c5be84c7c9d7a85c79fcc4e9732ecc5d0 100644 (file)
--- a/camlp4/unmaintained/lefteval/Makefile
+++ b/camlp4/unmaintained/lefteval/Makefile
@@ -1,12 +1,13 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #                                Camlp4                                 #
 #                                                                       #
 #   Copyright 2004 Institut National de Recherche en Informatique et    #
 #   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../../LICENSE.#
 #                                                                       #
 #########################################################################
 #

diff --git a/camlp4/unmaintained/lefteval/README b/camlp4/unmaintained/lefteval/README
index 809d42f2a8619a6d817c666831ae9f0e3a35e7ce..830402b65179b68c4115239ad2af1dac6c45cace 100644 (file)
--- a/camlp4/unmaintained/lefteval/README
+++ b/camlp4/unmaintained/lefteval/README
@@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing
 this package further and/or actively maintain it, please let us know
 (caml@inria.fr)
 
-This package is distributed under the same license as the Objective
-Caml Library (that is, LGPL with a special exception allowing both
+This package is distributed under the same license as the OCaml
+Library (that is, LGPL with a special exception allowing both
 static and dynamic link).
 
 -- Michel Mauny

diff --git a/camlp4/unmaintained/ocamllex/Makefile b/camlp4/unmaintained/ocamllex/Makefile
index b232023e58a9b1711f81f5d11446a4aaee8e182d..1407c40a6f8e220f96eca7666f7f43d326eceb6c 100644 (file)
--- a/camlp4/unmaintained/ocamllex/Makefile
+++ b/camlp4/unmaintained/ocamllex/Makefile
@@ -1,12 +1,13 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #                                Camlp4                                 #
 #                                                                       #
 #   Copyright 2004 Institut National de Recherche en Informatique et    #
 #   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../../LICENSE.#
 #                                                                       #
 #########################################################################
 #

diff --git a/camlp4/unmaintained/ocamllex/README b/camlp4/unmaintained/ocamllex/README
index 809d42f2a8619a6d817c666831ae9f0e3a35e7ce..830402b65179b68c4115239ad2af1dac6c45cace 100644 (file)
--- a/camlp4/unmaintained/ocamllex/README
+++ b/camlp4/unmaintained/ocamllex/README
@@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing
 this package further and/or actively maintain it, please let us know
 (caml@inria.fr)
 
-This package is distributed under the same license as the Objective
-Caml Library (that is, LGPL with a special exception allowing both
+This package is distributed under the same license as the OCaml
+Library (that is, LGPL with a special exception allowing both
 static and dynamic link).
 
 -- Michel Mauny

diff --git a/camlp4/unmaintained/ocpp/.cvsignore b/camlp4/unmaintained/ocpp/.cvsignore
deleted file mode 100644 (file)
index baef26c..0000000
--- a/camlp4/unmaintained/ocpp/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.cm[oia]
-ocpp
-crc.ml

diff --git a/camlp4/unmaintained/ocpp/.ignore b/camlp4/unmaintained/ocpp/.ignore
new file mode 100644 (file)
index 0000000..f992267
--- /dev/null
+++ b/camlp4/unmaintained/ocpp/.ignore
@@ -0,0 +1,2 @@
+ocpp
+crc.ml

diff --git a/camlp4/unmaintained/odyl/.cvsignore b/camlp4/unmaintained/odyl/.cvsignore
deleted file mode 100644 (file)
index 8ae0ebb..0000000
--- a/camlp4/unmaintained/odyl/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-*.cm[oia]
-odyl
-*.lib
-odyl_config.ml

diff --git a/camlp4/unmaintained/odyl/.ignore b/camlp4/unmaintained/odyl/.ignore
new file mode 100644 (file)
index 0000000..c270c79
--- /dev/null
+++ b/camlp4/unmaintained/odyl/.ignore
@@ -0,0 +1,3 @@
+odyl
+*.lib
+odyl_config.ml

diff --git a/camlp4/unmaintained/olabl/Makefile b/camlp4/unmaintained/olabl/Makefile
index f928d4589f23579885d9b9ea8a94334c98db3be8..2d9eb6904f78d9c6da358b43d3e2df1f590220ee 100644 (file)
--- a/camlp4/unmaintained/olabl/Makefile
+++ b/camlp4/unmaintained/olabl/Makefile
@@ -1,12 +1,13 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #                                Camlp4                                 #
 #                                                                       #
 #   Copyright 2004 Institut National de Recherche en Informatique et    #
 #   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../../LICENSE.#
 #                                                                       #
 #########################################################################
 #

diff --git a/camlp4/unmaintained/olabl/README b/camlp4/unmaintained/olabl/README
index 809d42f2a8619a6d817c666831ae9f0e3a35e7ce..830402b65179b68c4115239ad2af1dac6c45cace 100644 (file)
--- a/camlp4/unmaintained/olabl/README
+++ b/camlp4/unmaintained/olabl/README
@@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing
 this package further and/or actively maintain it, please let us know
 (caml@inria.fr)
 
-This package is distributed under the same license as the Objective
-Caml Library (that is, LGPL with a special exception allowing both
+This package is distributed under the same license as the OCaml
+Library (that is, LGPL with a special exception allowing both
 static and dynamic link).
 
 -- Michel Mauny

diff --git a/camlp4/unmaintained/olabl/pa_olabl.ml b/camlp4/unmaintained/olabl/pa_olabl.ml
index 285902a144943ee8dcf6c92e13729ff465d03d2f..da70a67563851460a45cb9b0f739b5a8d44f886f 100644 (file)
--- a/camlp4/unmaintained/olabl/pa_olabl.ml
+++ b/camlp4/unmaintained/olabl/pa_olabl.ml
@@ -1964,7 +1964,7 @@ value rec cstream gloc =
       else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
 ;
 
-(* Syntax extensions in Ocaml grammar *)
+(* Syntax extensions in OCaml grammar *)
 
 EXTEND
   GLOBAL: expr;

diff --git a/camlp4/unmaintained/scheme/Makefile b/camlp4/unmaintained/scheme/Makefile
index dd234bf9e16ce41011d5f6d5f37fa5f0b0a13c78..4034629fb53caade339f664929536f0980c8760d 100644 (file)
--- a/camlp4/unmaintained/scheme/Makefile
+++ b/camlp4/unmaintained/scheme/Makefile
@@ -1,12 +1,13 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #                                Camlp4                                 #
 #                                                                       #
 #   Copyright 2004 Institut National de Recherche en Informatique et    #
 #   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../../LICENSE.#
 #                                                                       #
 #########################################################################
 #
@@ -38,7 +39,7 @@ opt: all
 bootstrap: camlp4sch$(EXE) save
        ./camlp4sch$(EXE) ../../etc/q_phony.cmo ../../meta/pa_extend.cmo ../../etc/pr_r.cmo ../../etc/pr_extend.cmo ../../etc/pr_rp.cmo -impl pa_scheme.sc \
          | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' \
-               -e 's/$$Id$/File generated by pretty print; do not edit!/' > pa_scheme.ml
+               -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' > pa_scheme.ml
        @if cmp -s pa_scheme.ml SAVED/pa_scheme.ml; then \
                echo 'pa_scheme.ml and SAVED/pa_scheme.ml are identical' ; \
         else \
@@ -77,7 +78,7 @@ pr_schemep.cmo: pr_schp_main.cmo
 
 
 .ml.cmo:
-       $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< 
+       $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $<
 
 .ml.cmx:
        $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES)  `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $<

diff --git a/camlp4/unmaintained/scheme/README b/camlp4/unmaintained/scheme/README
index 809d42f2a8619a6d817c666831ae9f0e3a35e7ce..830402b65179b68c4115239ad2af1dac6c45cace 100644 (file)
--- a/camlp4/unmaintained/scheme/README
+++ b/camlp4/unmaintained/scheme/README
@@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing
 this package further and/or actively maintain it, please let us know
 (caml@inria.fr)
 
-This package is distributed under the same license as the Objective
-Caml Library (that is, LGPL with a special exception allowing both
+This package is distributed under the same license as the OCaml
+Library (that is, LGPL with a special exception allowing both
 static and dynamic link).
 
 -- Michel Mauny

diff --git a/camlp4/unmaintained/sml/Makefile b/camlp4/unmaintained/sml/Makefile
index ea3980bef4257da19f1e1e073f8947690b65f23e..80b1724253946e9ca9577c942d448a97fd27f923 100644 (file)
--- a/camlp4/unmaintained/sml/Makefile
+++ b/camlp4/unmaintained/sml/Makefile
@@ -1,12 +1,13 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #                                Camlp4                                 #
 #                                                                       #
 #   Copyright 2004 Institut National de Recherche en Informatique et    #
 #   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the Q Public License version 1.0.                #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../../LICENSE.#
 #                                                                       #
 #########################################################################
 #

diff --git a/camlp4/unmaintained/sml/README b/camlp4/unmaintained/sml/README
index 809d42f2a8619a6d817c666831ae9f0e3a35e7ce..830402b65179b68c4115239ad2af1dac6c45cace 100644 (file)
--- a/camlp4/unmaintained/sml/README
+++ b/camlp4/unmaintained/sml/README
@@ -7,8 +7,8 @@ accessible from the Camlp4 hump. If you are interested in developing
 this package further and/or actively maintain it, please let us know
 (caml@inria.fr)
 
-This package is distributed under the same license as the Objective
-Caml Library (that is, LGPL with a special exception allowing both
+This package is distributed under the same license as the OCaml
+Library (that is, LGPL with a special exception allowing both
 static and dynamic link).
 
 -- Michel Mauny

diff --git a/config/.cvsignore b/config/.cvsignore
deleted file mode 100644 (file)
index 9fc1c01..0000000
--- a/config/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-m.h
-s.h
-Makefile
-config.sh

diff --git a/config/.ignore b/config/.ignore
new file mode 100644 (file)
index 0000000..9fc1c01
--- /dev/null
+++ b/config/.ignore
@@ -0,0 +1,4 @@
+m.h
+s.h
+Makefile
+config.sh

diff --git a/config/Makefile-templ b/config/Makefile-templ
index dd65452a94b1e65d3c315ddb1e8674fdc50fe03c..626d30e84293361a5849b2efe7662336aef2cc1a 100644 (file)
--- a/config/Makefile-templ
+++ b/config/Makefile-templ
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -46,19 +46,15 @@ SHARPBANGSCRIPTS=true
 #BYTECC=cc
 
 ### Additional compile-time options for $(BYTECC).
-# If using gcc on Intel 386 or Motorola 68k:
+# If using gcc on Intel x86:
 # (the -fno-defer-pop option circumvents a bug in certain versions of gcc)
 #BYTECCCOMPOPTS=-fno-defer-pop -Wall
-# If using gcc and being superstitious:
+# If using gcc and being cautious:
 #BYTECCCOMPOPTS=-Wall
-# Under NextStep:
-#BYTECCCOMPOPTS=-U__GNUC__ -fno-defer-pop -Wall
 # Otherwise:
 #BYTECCCOMPOPTS=
 
 ### Additional link-time options for $(BYTECC)
-### If using GCC on a Dec Alpha under OSF1:
-#BYTECCLINKOPTS=-Wl,-T,12000000 -Wl,-D,14000000
 # To support dynamic loading of shared libraries (they need to look at
 # our own symbols):
 #BYTECCLINKOPTS=-Wl,-E
@@ -90,6 +86,9 @@ RANLIBCMD=ranlib
 #RANLIB=ar rs
 #RANLIBCMD=
 
+### How to invoke ar
+#ARCMD=ar
+
 ### Shared library support
 # Extension for shared libraries: so if supported, a if not supported
 #SO=so
@@ -111,23 +110,15 @@ RANLIBCMD=ranlib
 ### Name of architecture for the native-code compiler
 ### Currently supported:
 ###
-### alpha       Digital/Compaq Alpha machines under DUnix/Tru64 or Linux
 ### i386        Intel Pentium PCs under Linux, *BSD*, NextStep
 ### sparc       Sun Sparcstation under SunOS 4.1 or Solaris 2
-### mips        SGI machines under IRIX
-### hppa        HP 9000/700 under HPUX and Linux
 ### power       Macintosh under Mac OS X and Linux
-### ia64        Intel Itanium/IA64 under Linux
 ### arm         ARM under Linux
 ###
 ### Set ARCH=none if your machine is not supported
-#ARCH=alpha
 #ARCH=i386
 #ARCH=sparc
-#ARCH=mips
-#ARCH=hppa
 #ARCH=power
-#ARCH=ia64
 #ARCH=arm
 #ARCH=none
 
@@ -144,37 +135,18 @@ RANLIBCMD=ranlib
 #MODEL=default
 
 ### Name of operating system family for the native-code compiler.
-### If ARCH=sparc: choose between
-###   SYSTEM=sunos      SunOS 4.1
-###   SYSTEM=solaris    Solaris 2
-###
-### If ARCH=i386:  choose between
-###   SYSTEM=linux_aout Linux with a.out binaries
-###   SYSTEM=linux_elf  Linux with ELF binaries
-###   SYSTEM=bsd        FreeBSD, probably works for NetBSD also
-###   SYSTEM=nextstep   NextStep
-###
-### For other architectures: set SYSTEM=unknown
-###
-#SYSTEM=sunos
 #SYSTEM=solaris
 #SYSTEM=linux
 #SYSTEM=linux_elf
 #SYSTEM=bsd
-#SYSTEM=nextstep
 #SYSTEM=unknown
 
 ### Which C compiler to use for the native-code compiler.
-### cc is better than gcc on the Mips and Alpha.
 #NATIVECC=cc
 #NATIVECC=gcc
 
 ### Additional compile-time options for $(NATIVECC).
-# For cc on the Alpha:
-#NATIVECCCOMPOPTS=-std1
-# For cc on the Mips:
-#NATIVECCCOMPOPTS=-std
-# For gcc if superstitious:
+# For gcc if cautious:
 #NATIVECCCOMPOPTS=-Wall
 
 ### Additional link-time options for $(NATIVECC)
@@ -185,29 +157,21 @@ RANLIBCMD=ranlib
 #NATIVECCRPATH=-Wl,-rpath
 
 ### Command and flags to use for assembling ocamlopt-generated code
-# For the Alpha or the Mips:
-#AS=as -O2
-# For the PowerPC:
-#AS=as -u -m ppc -w
-# Otherwise:
-#AS=as
+#ASM=as
 
 ### Command and flags to use for assembling .S files (often with preprocessing)
 # If gcc is available:
 #ASPP=gcc -c
-# On SunOS and Solaris:
+# On Solaris:
 #ASPP=as -P
 
 ### Extra flags to use for assembling .S files in profiling mode
-# On Digital Unix:
-#ASPPPROFFLAGS=-pg -DPROFILING
-# Otherwise:
 #ASPPPROFFLAGS=-DPROFILING
 
 ### Whether profiling with gprof is supported
-# If yes: (x86/Linux, Alpha/Digital Unix, Sparc/Solaris):
+# If yes: (e.g. x86/Linux, Sparc/Solaris):
 #PROFILING=prof
-# If no: (all others)
+# If no:
 #PROFILING=noprof
 
 ### Option to give to the C compiler for profiling
@@ -238,8 +202,6 @@ OTHERLIBRARIES=unix str num threads graph dynlink labltk bigarray
 #      generic (portable C, works everywhere)
 #      ia32    (Intel x86)
 #      amd64   (AMD Opteron, Athlon64)
-#       alpha
-#      mips
 #      ppc     (Power PC)
 #      sparc
 # If you don't know, leave BNG_ARCH=generic, which selects a portable
@@ -268,13 +230,6 @@ BNG_ASM_LEVEL=1
 # For SunOS with OpenLook:
 #X11_LINK=-L$(X11_LIB) -lX11
 
-### -I options for finding the include file ndbm.h
-# Needed for the "dbm" package
-# Usually:
-#DBM_INCLUDES=
-# For recent Linux systems:
-#DBM_INCLUDES=-I/usr/include/gdbm
-
 ### Preprocessor options for finding tcl.h and tk.h
 # Needed for the "labltk" package
 # Required only if not in the standard include path.

diff --git a/config/Makefile.mingw b/config/Makefile.mingw
index f2e408cc0ee3958428c1dea3347c3409fa985183..ddbc62872792fd429b6f3c3dec16ef0da2e43126 100644 (file)
--- a/config/Makefile.mingw
+++ b/config/Makefile.mingw
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -19,6 +19,9 @@
 
 PREFIX=C:/ocamlmgw
 
+### Remove this to disable compiling camlp4
+CAMLP4=camlp4
+
 ### Where to install the binaries
 BINDIR=$(PREFIX)/bin
 
@@ -37,6 +40,10 @@ MANDIR=$(PREFIX)/man
 ########## Toolchain and OS dependencies
 
 TOOLCHAIN=mingw
+
+### Toolchain prefix
+TOOLPREF=i686-w64-mingw32-
+
 CCOMPTYPE=cc
 O=o
 A=a
@@ -61,10 +68,11 @@ SHAREDCCCOMPOPTS=
 MKSHAREDLIBRPATH=
 NATIVECCPROFOPTS=
 NATIVECCRPATH=
-ASM=as
+ASM=$(TOOLPREF)as
 ASPP=gcc
 ASPPPROFFLAGS=
 PROFILING=noprof
+RUNTIMED=noruntimed
 DYNLINKOPTS=
 DEBUGGER=ocamldebugger
 CC_PROFILE=
@@ -72,11 +80,13 @@ SYSTHREAD_SUPPORT=true
 EXTRALIBS=
 NATDYNLINK=true
 CMXS=cmxs
+RUNTIMED=noruntimed
+ASM_CFI_SUPPORTED=false
 
 ########## Configuration for the bytecode compiler
 
 ### Which C compiler to use for the bytecode interpreter.
-BYTECC=gcc -mno-cygwin
+BYTECC=$(TOOLPREF)gcc
 
 ### Additional compile-time options for $(BYTECC).  (For static linking.)
 BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
@@ -95,7 +105,7 @@ NATIVECCLIBS=-lws2_32
 CPP=$(BYTECC) -E
 
 ### Flexlink
-FLEXLINK=flexlink -chain mingw
+FLEXLINK=flexlink -chain mingw -stack 16777216
 FLEXDIR=$(shell $(FLEXLINK) -where)
 IFLEXDIR=-I"$(FLEXDIR)"
 MKDLL=$(FLEXLINK)
@@ -103,16 +113,19 @@ MKEXE=$(FLEXLINK) -exe
 MKMAINDLL=$(FLEXLINK) -maindll
 
 ### How to build a static library
-MKLIB=rm -f $(1); ar rcs $(1) $(2)
-#ml let mklib out files opts = Printf.sprintf "rm -f %s && ar rcs %s %s %s" out opts out files;;
+MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1)
+#ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;;
 
 ### Canonicalize the name of a system library
 SYSLIB=-l$(1)
 #ml let syslib x = "-l"^x;;
 
 ### The ranlib command
-RANLIB=ranlib
-RANLIBCMD=ranlib
+RANLIB=$(TOOLPREF)ranlib
+RANLIBCMD=$(TOOLPREF)ranlib
+
+### The ar command
+ARCMD=$(TOOLPREF)ar
 
 ############# Configuration for the native-code compiler
 
@@ -135,7 +148,7 @@ NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
 NATIVECCLINKOPTS=
 
 ### Build partially-linked object file
-PACKLD=ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o'
+PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o'
 
 ############# Configuration for the contributed libraries
 

diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64
new file mode 100644 (file)
index 0000000..86dd90a
--- /dev/null
+++ b/config/Makefile.mingw64
@@ -0,0 +1,164 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 1999 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
+# $Id: Makefile.mingw 11319 2011-12-16 17:02:48Z xleroy $
+
+# Configuration for Windows, Mingw compiler
+
+######### General configuration
+
+PREFIX=C:/ocamlmgw64
+
+### Where to install the binaries
+BINDIR=$(PREFIX)/bin
+
+### Where to install the standard library
+LIBDIR=$(PREFIX)/lib
+
+### Where to install the stub DLLs
+STUBLIBDIR=$(LIBDIR)/stublibs
+
+### Where to install the info files
+DISTRIB=$(PREFIX)
+
+### Where to install the man pages
+MANDIR=$(PREFIX)/man
+
+########## Toolchain and OS dependencies
+
+TOOLCHAIN=mingw
+
+### Toolchain prefix
+TOOLPREF=x86_64-w64-mingw32-
+
+CCOMPTYPE=cc
+O=o
+A=a
+S=s
+SO=s.o
+DO=d.o
+EXE=.exe
+EXT_DLL=.dll
+EXT_OBJ=.$(O)
+EXT_LIB=.$(A)
+EXT_ASM=.$(S)
+MANEXT=1
+SHARPBANGSCRIPTS=false
+PTHREAD_LINK=
+X11_INCLUDES=
+X11_LINK=
+DBM_INCLUDES=
+DBM_LINK=
+BYTECCRPATH=
+SUPPORTS_SHARED_LIBRARIES=true
+SHAREDCCCOMPOPTS=
+MKSHAREDLIBRPATH=
+NATIVECCPROFOPTS=
+NATIVECCRPATH=
+ASM=$(TOOLPREF)as
+ASPP=gcc
+ASPPPROFFLAGS=
+PROFILING=noprof
+RUNTIMED=noruntimed
+DYNLINKOPTS=
+DEBUGGER=ocamldebugger
+CC_PROFILE=
+SYSTHREAD_SUPPORT=true
+EXTRALIBS=
+NATDYNLINK=true
+CMXS=cmxs
+RUNTIMED=noruntimed
+
+########## Configuration for the bytecode compiler
+
+### Which C compiler to use for the bytecode interpreter.
+BYTECC=$(TOOLPREF)gcc
+
+### Additional compile-time options for $(BYTECC).  (For static linking.)
+BYTECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
+
+### Additional link-time options for $(BYTECC).  (For static linking.)
+BYTECCLINKOPTS=
+
+### Additional compile-time options for $(BYTECC).  (For building a DLL.)
+DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL
+
+### Libraries needed
+BYTECCLIBS=-lws2_32
+NATIVECCLIBS=-lws2_32
+
+### How to invoke the C preprocessor
+CPP=$(BYTECC) -E
+
+### Flexlink
+FLEXLINK=flexlink -chain mingw64 -stack 33554432
+FLEXDIR=$(shell $(FLEXLINK) -where)
+IFLEXDIR=-I"$(FLEXDIR)"
+MKDLL=$(FLEXLINK)
+MKEXE=$(FLEXLINK) -exe
+MKMAINDLL=$(FLEXLINK) -maindll
+
+### How to build a static library
+MKLIB=rm -f $(1); $(TOOLPREF)ar rc $(1) $(2); $(RANLIB) $(1)
+#ml let mklib out files opts = Printf.sprintf "rm -f %s && %sar rcs %s %s %s" out toolpref opts out files;;
+
+### Canonicalize the name of a system library
+SYSLIB=-l$(1)
+#ml let syslib x = "-l"^x;;
+
+### The ranlib command
+RANLIB=$(TOOLPREF)ranlib
+RANLIBCMD=$(TOOLPREF)ranlib
+
+### The ar command
+ARCMD=$(TOOLPREF)ar
+
+############# Configuration for the native-code compiler
+
+### Name of architecture for the native-code compiler
+ARCH=amd64
+
+### Name of architecture model for the native-code compiler.
+MODEL=default
+
+### Name of operating system family for the native-code compiler.
+SYSTEM=mingw64
+
+### Which C compiler to use for the native-code compiler.
+NATIVECC=$(BYTECC)
+
+### Additional compile-time options for $(NATIVECC).
+NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused
+
+### Additional link-time options for $(NATIVECC)
+NATIVECCLINKOPTS=
+
+### Build partially-linked object file
+PACKLD=$(TOOLPREF)ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o'
+
+############# Configuration for the contributed libraries
+
+OTHERLIBRARIES=win32unix str num win32graph dynlink bigarray systhreads
+
+### Name of the target architecture for the "num" library
+BNG_ARCH=amd64
+BNG_ASM_LEVEL=1
+
+### Configuration for LablTk (not supported)
+TK_DEFS=
+TK_LINK=
+
+############# Aliases for common commands
+
+MAKEREC=$(MAKE) -f Makefile.nt
+MAKECMD=$(MAKE)

diff --git a/config/Makefile.msvc b/config/Makefile.msvc
index 8f0a50ce43620ecad444784e8d0a0d374a2e64cd..ff96ea27dc577f890af7c19979f5759f743eda16 100644 (file)
--- a/config/Makefile.msvc
+++ b/config/Makefile.msvc
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -71,6 +71,7 @@ SYSTHREAD_SUPPORT=true
 EXTRALIBS=
 CMXS=cmxs
 NATDYNLINK=true
+RUNTIMED=noruntimed
 
 ########## Configuration for the bytecode compiler
 
@@ -94,11 +95,11 @@ NATIVECCLIBS=advapi32.lib ws2_32.lib
 CPP=cl /nologo /EP
 
 ### Flexlink
-FLEXLINK=flexlink -merge-manifest
+FLEXLINK=flexlink -merge-manifest -stack 16777216
 FLEXDIR=$(shell $(FLEXLINK) -where)
 IFLEXDIR=-I"$(FLEXDIR)"
 MKDLL=$(FLEXLINK)
-MKEXE=$(FLEXLINK) -exe -link /STACK:16777216
+MKEXE=$(FLEXLINK) -exe
 MKMAINDLL=$(FLEXLINK) -maindll
 
 ### How to build a static library
@@ -114,6 +115,9 @@ SYSLIB=$(1).lib
 RANLIB=echo
 RANLIBCMD=
 
+### The ar command
+ARCMD=
+
 ############# Configuration for the native-code compiler
 
 ### Name of architecture for the native-code compiler
@@ -137,6 +141,13 @@ NATIVECCLINKOPTS=
 ### Build partially-linked object file
 PACKLD=link /lib /nologo /out:# there must be no space after this '/out:'
 
+############# Configuration for camlp4
+
+# This variable controls whether camlp4 will be built.
+# If it is set to camlp4, then it will be built.
+# If it is set to the empty string, then it will not be built.
+CAMLP4=camlp4
+
 ############# Configuration for the contributed libraries
 
 OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk

diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64
index e91b26f72428ca197a7fa70940a64c0daca8f77f..b6c2c6bc197d6146b215e62f916b53c9a69cd243 100644 (file)
--- a/config/Makefile.msvc64
+++ b/config/Makefile.msvc64
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -71,6 +71,7 @@ CC_PROFILE=
 SYSTHREAD_SUPPORT=true
 CMXS=cmxs
 NATDYNLINK=true
+RUNTIMED=noruntimed
 
 ########## Configuration for the bytecode compiler
 
@@ -99,11 +100,11 @@ NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS)
 CPP=cl /nologo /EP
 
 ### Flexlink
-FLEXLINK=flexlink -x64 -merge-manifest
+FLEXLINK=flexlink -x64 -merge-manifest -stack 33554432
 FLEXDIR=$(shell $(FLEXLINK) -where)
 IFLEXDIR=-I"$(FLEXDIR)"
 MKDLL=$(FLEXLINK)
-MKEXE=$(FLEXLINK) -exe -link /STACK:33554432
+MKEXE=$(FLEXLINK) -exe
 MKMAINDLL=$(FLEXLINK) -maindll
 
 ### How to build a static library
@@ -119,6 +120,9 @@ SYSLIB=$(1).lib
 RANLIB=echo
 RANLIBCMD=
 
+### The ar command
+ARCMD=
+
 ############# Configuration for the native-code compiler
 
 ### Name of architecture for the native-code compiler

diff --git a/config/auto-aux/.cvsignore b/config/auto-aux/.cvsignore
deleted file mode 100644 (file)
index cb1ca8a..0000000
--- a/config/auto-aux/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-camlp4_config.ml

diff --git a/config/auto-aux/.ignore b/config/auto-aux/.ignore
new file mode 100644 (file)
index 0000000..cb1ca8a
--- /dev/null
+++ b/config/auto-aux/.ignore
@@ -0,0 +1 @@
+camlp4_config.ml

diff --git a/config/auto-aux/align.c b/config/auto-aux/align.c
index 0bedf77a02407a9d52dcbacb952c3fb433abeda1..a04684b48391286737b7311f17a483306988f378 100644 (file)
--- a/config/auto-aux/align.c
+++ b/config/auto-aux/align.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/ansi.c b/config/auto-aux/ansi.c
index f1a416b857fa93d403eac6c3e7243d9fe3ed128c..01d46252aeeb364e61b5b554302e64aad827cf6e 100644 (file)
--- a/config/auto-aux/ansi.c
+++ b/config/auto-aux/ansi.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/async_io.c b/config/auto-aux/async_io.c
index 2b5faa2d70ccd9af3e5a1b171de008dadc0f78f8..2ce3da725aceeb0b437e8a7ebe50a40328086e18 100644 (file)
--- a/config/auto-aux/async_io.c
+++ b/config/auto-aux/async_io.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/bytecopy.c b/config/auto-aux/bytecopy.c
index 923b444e5bcfe4df04b1054c75149ab74f14111b..2006147fd7454c54373be7444ee4e0391a1acde5 100644 (file)
--- a/config/auto-aux/bytecopy.c
+++ b/config/auto-aux/bytecopy.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/cfi.S b/config/auto-aux/cfi.S
new file mode 100644 (file)
index 0000000..e055423
--- /dev/null
+++ b/config/auto-aux/cfi.S
@@ -0,0 +1,3 @@
+.cfi_startproc
+.cfi_adjust_cfa_offset 8
+.cfi_endproc

diff --git a/config/auto-aux/dblalign.c b/config/auto-aux/dblalign.c
index c2520381ce1434d81002a116cfa1537fb7d79215..91d4194c09acc93ca86ea18c0be74d10e72479e9 100644 (file)
--- a/config/auto-aux/dblalign.c
+++ b/config/auto-aux/dblalign.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/divmod.c b/config/auto-aux/divmod.c
index 8f69dabf350da1ddf7471d533b108142a788bd27..d59bf31cc9c84ad7cffee300df1de533633fa579 100644 (file)
--- a/config/auto-aux/divmod.c
+++ b/config/auto-aux/divmod.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/elf.c b/config/auto-aux/elf.c
index 026c4838ebf380ca7ce7f9132cc50057f141ac19..27be98d6b734845fac5fa69c3ad26093a24fcbcd 100644 (file)
--- a/config/auto-aux/elf.c
+++ b/config/auto-aux/elf.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/endian.c b/config/auto-aux/endian.c
index def617f0f5c0fcd1be2c45c09df4174119cab485..b019eb1c7a6d0a6dc1683f2403a649b5690e0bc0 100644 (file)
--- a/config/auto-aux/endian.c
+++ b/config/auto-aux/endian.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/expm1.c b/config/auto-aux/expm1.c
index be41d0231c7b75a192058aea1bda188f963ad662..db4413b92ba196338bbecafbcaeee8068007ba6e 100644 (file)
--- a/config/auto-aux/expm1.c
+++ b/config/auto-aux/expm1.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/getgroups.c b/config/auto-aux/getgroups.c
index 1ed8a1fbb1331ea98d90cd4e196f4100f8514a5c..b69b0be41f27e2bd8f5c2264a63680994df416ca 100644 (file)
--- a/config/auto-aux/getgroups.c
+++ b/config/auto-aux/getgroups.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/gethostbyaddr.c b/config/auto-aux/gethostbyaddr.c
index c5dd129719b568a1c2f9dd24a122ffeb9b6e4bd8..f6d36a7f3b7831438c1049f30539f679f5542323 100644 (file)
--- a/config/auto-aux/gethostbyaddr.c
+++ b/config/auto-aux/gethostbyaddr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/gethostbyname.c b/config/auto-aux/gethostbyname.c
index 043b9d33436ac6bce9d8a6e3552ff2b9ac351c58..96a39438d515554f52398ba13aad1a0efeb4d903 100644 (file)
--- a/config/auto-aux/gethostbyname.c
+++ b/config/auto-aux/gethostbyname.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/hasgot b/config/auto-aux/hasgot
index 5014b903d7adbee9f6a8fe864157bbca050df6c6..53d578660beb48157a8d07e12210e9523bd7b4f3 100755 (executable)
--- a/config/auto-aux/hasgot
+++ b/config/auto-aux/hasgot
@@ -1,5 +1,18 @@
 #!/bin/sh
 
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 1995 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../LICENSE.   #
+#                                                                       #
+#########################################################################
+
 opts=""
 libs="$cclibs"
 args=$*

diff --git a/config/auto-aux/hasgot2 b/config/auto-aux/hasgot2
new file mode 100644 (file)
index 0000000..0e9cef9
--- /dev/null
+++ b/config/auto-aux/hasgot2
@@ -0,0 +1,42 @@
+#!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2011 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../LICENSE.   #
+#                                                                       #
+#########################################################################
+
+opts=""
+libs="$cclibs"
+args=$*
+rm -f hasgot.c
+var="x"
+while : ; do
+  case "$1" in
+    -i) echo "#include <$2>" >> hasgot.c; shift;;
+    -t) echo "$2 $var;" >> hasgot.c; var="x$var"; shift;;
+    -l*|-L*|-F*) libs="$libs $1";;
+    -framework) libs="$libs $1 $2"; shift;;
+    -*) opts="$opts $1";;
+     *) break;;
+  esac
+  shift
+done
+
+(echo "main() {"
+ for f in $*; do echo "  (void) & $f;"; done
+ echo "}") >> hasgot.c
+
+if test "$verbose" = yes; then
+  echo "hasgot2 $args: $cc $opts -o tst hasgot.c $libs" >&2
+  exec $cc $opts -o tst hasgot.c $libs > /dev/null
+else
+  exec $cc $opts -o tst hasgot.c $libs > /dev/null 2>/dev/null
+fi

diff --git a/config/auto-aux/ia32sse2.c b/config/auto-aux/ia32sse2.c
index cbe114626a8bc2fe9a46351b22e016bfc836704a..8ba81601b6e46f50f4f96daef1afdbcf4f730a93 100644 (file)
--- a/config/auto-aux/ia32sse2.c
+++ b/config/auto-aux/ia32sse2.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/initgroups.c b/config/auto-aux/initgroups.c
index b6e0ffbdf278751f520ef568df3d35b7e96e92d9..7b9c2398348e58351f01b7fb2c9d6826fdc09902 100644 (file)
--- a/config/auto-aux/initgroups.c
+++ b/config/auto-aux/initgroups.c
@@ -1,6 +1,8 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
+/*                                                                     */
+/*  Contributed by Stephane Glondu <steph@glondu.net>                  */
 /*                                                                     */
 /*  Copyright 2009 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
@@ -9,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* Contributed by Stephane Glondu <steph@glondu.net> */
-
 /* $Id$ */
 
 #include <errno.h>

diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c
index 6bdd25567a53541b03b97f490a68c66655b3a761..b087a3d66b6140c00963729f87d5311d1006eef8 100644 (file)
--- a/config/auto-aux/int64align.c
+++ b/config/auto-aux/int64align.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/longlong.c b/config/auto-aux/longlong.c
index bcdf4c974ba56d987e4b80c0790d87a9d28282f2..424e540fdfb08573b94d9047c64105f1c6a18745 100644 (file)
--- a/config/auto-aux/longlong.c
+++ b/config/auto-aux/longlong.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/runtest b/config/auto-aux/runtest
index ce65bd07f1c525492117461fe89875ab729047cf..c8d7c435a41a8ab7b2c97a8c55d26585a468b100 100755 (executable)
--- a/config/auto-aux/runtest
+++ b/config/auto-aux/runtest
@@ -1,4 +1,18 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 1995 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../LICENSE.   #
+#                                                                       #
+#########################################################################
+
 if test "$verbose" = yes; then
 echo "runtest: $cc -o tst $* $cclibs" >&2
 $cc -o tst $* $cclibs || exit 100

diff --git a/config/auto-aux/schar.c b/config/auto-aux/schar.c
index 55d49f31a7a3b5f3f320926b038029f3f378da52..e3e81e395eb58bb795dc285c35917fe00944dcb1 100644 (file)
--- a/config/auto-aux/schar.c
+++ b/config/auto-aux/schar.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/schar2.c b/config/auto-aux/schar2.c
index d1d781a53ecb3888c86bbc4b5a593d32b6476fb3..d041af1830dc2d63d2a113ed4b4bf294268f9ea7 100644 (file)
--- a/config/auto-aux/schar2.c
+++ b/config/auto-aux/schar2.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/searchpath b/config/auto-aux/searchpath
index 9b31267f67a50aaac75862c521d6ff5df92b68e4..79d7fcaebcf76feca4124e6aefccd1e76c9077ec 100755 (executable)
--- a/config/auto-aux/searchpath
+++ b/config/auto-aux/searchpath
@@ -1,4 +1,18 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 1996 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../LICENSE.   #
+#                                                                       #
+#########################################################################
+
 # Find a program in the path
 
 IFS=':'

diff --git a/config/auto-aux/setgroups.c b/config/auto-aux/setgroups.c
index 5cfe49c08231a4cf8fe60e4fd431dedb172b552b..63ac1b8c34e15a6682fdb6d23977622208293bed 100644 (file)
--- a/config/auto-aux/setgroups.c
+++ b/config/auto-aux/setgroups.c
@@ -1,6 +1,8 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
+/*                                                                     */
+/*  Contributed by Stephane Glondu <steph@glondu.net>                  */
 /*                                                                     */
 /*  Copyright 2009 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
@@ -9,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* Contributed by Stephane Glondu <steph@glondu.net> */
-
 /* $Id$ */
 
 #include <errno.h>

diff --git a/config/auto-aux/sighandler.c b/config/auto-aux/sighandler.c
index 7e748df572d49e33a34e1e513c2e05dbb7175e1a..b36557c5f06e3c016bbfa7b79d2ca85f3a68f8da 100644 (file)
--- a/config/auto-aux/sighandler.c
+++ b/config/auto-aux/sighandler.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/signals.c b/config/auto-aux/signals.c
index df0a8b0b500fa988ebea870455eb348e62c5bbfd..78ba8de69d5775241a6185c9e2ada701fe2e9cf4 100644 (file)
--- a/config/auto-aux/signals.c
+++ b/config/auto-aux/signals.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/sizes.c b/config/auto-aux/sizes.c
index 992c47a658788d3f21bc117e83c4303dcde4458e..58fd6b23fc049cb39f7ce6e63eb96f715e52cefe 100644 (file)
--- a/config/auto-aux/sizes.c
+++ b/config/auto-aux/sizes.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/solaris-ld b/config/auto-aux/solaris-ld
index 3ab90bceff74a7dc721ad017a29848ab21cc143d..cc846a31b3827f21207440ef1b78e5397c605e62 100644 (file)
--- a/config/auto-aux/solaris-ld
+++ b/config/auto-aux/solaris-ld
@@ -1,4 +1,18 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2001 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../LICENSE.   #
+#                                                                       #
+#########################################################################
+
 # Determine if gcc calls the Solaris ld or the GNU ld
 # Exit code is 0 for Solaris ld, 1 for GNU ld
 

diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c
index 39e4e832be6adc9a4fe3d68b9b7cf7354c489c2b..47f252aa670531cf32399360eb4b3531000b87b6 100644 (file)
--- a/config/auto-aux/stackov.c
+++ b/config/auto-aux/stackov.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/auto-aux/tclversion.c b/config/auto-aux/tclversion.c
index 77c0bb729e2b106fa43e185f08c35a1b790305f5..84a94033c69fe2f9ea6fea436a837872bd1b602f 100644 (file)
--- a/config/auto-aux/tclversion.c
+++ b/config/auto-aux/tclversion.c
@@ -1,3 +1,21 @@
+/***********************************************************************/
+/*                                                                     */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
+/*                                                                     */
+/*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
+/*               projet Cristal, INRIA Rocquencourt                    */
+/*            Jacques Garrigue, Kyoto University RIMS                  */
+/*                                                                     */
+/*  Copyright 2002 Institut National de Recherche en Informatique et   */
+/*  en Automatique and Kyoto University.  All rights reserved.         */
+/*  This file is distributed under the terms of the GNU Library        */
+/*  General Public License, with the special exception on linking      */
+/*  described in file LICENSE found in the OCaml source tree.          */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
 #include <stdio.h>
 #include <tcl.h>
 #include <tk.h>

diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble
new file mode 100644 (file)
index 0000000..feffbed
--- /dev/null
+++ b/config/auto-aux/tryassemble
@@ -0,0 +1,7 @@
+#!/bin/sh
+if test "$verbose" = yes; then
+echo "tryassemble: $aspp -o tst $*" >&2
+$aspp -o tst $* || exit 100
+else
+$aspp -o tst $* 2> /dev/null || exit 100
+fi

diff --git a/config/auto-aux/trycompile b/config/auto-aux/trycompile
index 797a1c38697b35ab2f2aa7b277f27962c6e10936..934a00a9b7122a2dc349a4462f9ec9d68145f32b 100755 (executable)
--- a/config/auto-aux/trycompile
+++ b/config/auto-aux/trycompile
@@ -1,4 +1,18 @@
 #!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2002 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../../LICENSE.   #
+#                                                                       #
+#########################################################################
+
 if test "$verbose" = yes; then
 echo "trycompile: $cc -o tst $* $cclibs" >&2
 $cc -o tst $* $cclibs || exit 100

diff --git a/config/gnu/config.guess b/config/gnu/config.guess
index d25d58fe486d4666bf81c42a14bd57560d5b55cc..8152efd6756bb2dcae6cc5759aa8cebbdfb5b140 100755 (executable)
--- a/config/gnu/config.guess
+++ b/config/gnu/config.guess
@@ -1,9 +1,10 @@
 #! /bin/sh
 # Attempt to guess a canonical system name.
 #   Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-#   2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+#   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+#   2011 Free Software Foundation, Inc.
 
-timestamp='2004-02-16'
+timestamp='2011-11-11'
 
 # This file is free software; you can redistribute it and/or modify it
 # under the terms of the GNU General Public License as published by
@@ -17,23 +18,25 @@ timestamp='2004-02-16'
 #
 # You should have received a copy of the GNU General Public License
 # along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
+# 02110-1301, USA.
 #
 # As a special exception to the GNU General Public License, if you
 # distribute this file as part of a program that contains a
 # configuration script generated by Autoconf, you may include it under
 # the same distribution terms that you use for the rest of that program.
 
-# Originally written by Per Bothner <per@bothner.com>.
-# Please send patches to <config-patches@gnu.org>.  Submit a context
-# diff and a properly formatted ChangeLog entry.
+
+# Originally written by Per Bothner.  Please send patches (context
+# diff format) to <config-patches@gnu.org> and include a ChangeLog
+# entry.
 #
 # This script attempts to guess a canonical system name similar to
 # config.sub.  If it succeeds, it prints the system name on stdout, and
 # exits with 0.  Otherwise, it exits with 1.
 #
-# The plan is that this can be called by configure scripts if you
-# don't specify an explicit build system type.
+# You can get the latest version of this script from:
+# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD
 
 me=`echo "$0" | sed -e 's,.*/,,'`
 
@@ -53,8 +56,9 @@ version="\
 GNU config.guess ($timestamp)
 
 Originally written by Per Bothner.
-Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
-Free Software Foundation, Inc.
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free
+Software Foundation, Inc.
 
 This is free software; see the source for copying conditions.  There is NO
 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
@@ -66,11 +70,11 @@ Try \`$me --help' for more information."
 while test $# -gt 0 ; do
   case $1 in
     --time-stamp | --time* | -t )
-       echo "$timestamp" ; exit 0 ;;
+       echo "$timestamp" ; exit ;;
     --version | -v )
-       echo "$version" ; exit 0 ;;
+       echo "$version" ; exit ;;
     --help | --h* | -h )
-       echo "$usage"; exit 0 ;;
+       echo "$usage"; exit ;;
     -- )     # Stop option processing
        shift; break ;;
     - )        # Use stdin as input.
@@ -104,7 +108,7 @@ set_cc_for_build='
 trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ;
 trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ;
 : ${TMPDIR=/tmp} ;
- { tmp=`(umask 077 && mktemp -d -q "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
+ { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } ||
  { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } ||
  { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } ||
  { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ;
@@ -123,7 +127,7 @@ case $CC_FOR_BUILD,$HOST_CC,$CC in
        ;;
  ,,*)   CC_FOR_BUILD=$CC ;;
  ,*,*)  CC_FOR_BUILD=$HOST_CC ;;
-esac ;'
+esac ; set_cc_for_build= ;'
 
 # This is needed to find uname on a Pyramid OSx when run in the BSD universe.
 # (ghazi@noc.rutgers.edu 1994-08-24)
@@ -158,6 +162,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
            arm*) machine=arm-unknown ;;
            sh3el) machine=shl-unknown ;;
            sh3eb) machine=sh-unknown ;;
+           sh5el) machine=sh5le-unknown ;;
            *) machine=${UNAME_MACHINE_ARCH}-unknown ;;
        esac
        # The Operating System including object format, if it has switched
@@ -166,7 +171,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
            arm*|i386|m68k|ns32k|sh3*|sparc|vax)
                eval $set_cc_for_build
                if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \
-                       | grep __ELF__ >/dev/null
+                       | grep -q __ELF__
                then
                    # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout).
                    # Return netbsd for either.  FIX?
@@ -176,7 +181,7 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
                fi
                ;;
            *)
-               os=netbsd
+               os=netbsd
                ;;
        esac
        # The OS release
@@ -196,68 +201,32 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
        # contains redundant information, the shorter form:
        # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used.
        echo "${machine}-${os}${release}"
-       exit 0 ;;
-    amd64:OpenBSD:*:*)
-       echo x86_64-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    amiga:OpenBSD:*:*)
-       echo m68k-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    arc:OpenBSD:*:*)
-       echo mipsel-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    cats:OpenBSD:*:*)
-       echo arm-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    hp300:OpenBSD:*:*)
-       echo m68k-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    mac68k:OpenBSD:*:*)
-       echo m68k-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    macppc:OpenBSD:*:*)
-       echo powerpc-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    mvme68k:OpenBSD:*:*)
-       echo m68k-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    mvme88k:OpenBSD:*:*)
-       echo m88k-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    mvmeppc:OpenBSD:*:*)
-       echo powerpc-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    pegasos:OpenBSD:*:*)
-       echo powerpc-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    pmax:OpenBSD:*:*)
-       echo mipsel-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    sgi:OpenBSD:*:*)
-       echo mipseb-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    sun3:OpenBSD:*:*)
-       echo m68k-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
-    wgrisc:OpenBSD:*:*)
-       echo mipsel-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:OpenBSD:*:*)
-       echo ${UNAME_MACHINE}-unknown-openbsd${UNAME_RELEASE}
-       exit 0 ;;
+       UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'`
+       echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE}
+       exit ;;
     *:ekkoBSD:*:*)
        echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
+    *:SolidBSD:*:*)
+       echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE}
+       exit ;;
     macppc:MirBSD:*:*)
-       echo powerppc-unknown-mirbsd${UNAME_RELEASE}
-       exit 0 ;;
+       echo powerpc-unknown-mirbsd${UNAME_RELEASE}
+       exit ;;
     *:MirBSD:*:*)
        echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     alpha:OSF1:*:*)
-       if test $UNAME_RELEASE = "V4.0"; then
+       case $UNAME_RELEASE in
+       *4.0)
                UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`
-       fi
+               ;;
+       *5.*)
+               UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'`
+               ;;
+       esac
        # According to Compaq, /usr/sbin/psrinfo has been available on
        # OSF/1 and Tru64 systems produced since 1995.  I hope that
        # covers most systems running today.  This code pipes the CPU
@@ -295,45 +264,52 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
            "EV7.9 (21364A)")
                UNAME_MACHINE="alphaev79" ;;
        esac
+       # A Pn.n version is a patched version.
        # A Vn.n version is a released version.
        # A Tn.n version is a released field test version.
        # A Xn.n version is an unreleased experimental baselevel.
        # 1.2 uses "1.2" for uname -r.
-       echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
-       exit 0 ;;
-    Alpha*:OpenVMS:*:*)
-       echo alpha-hp-vms
-       exit 0 ;;
+       echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
+       # Reset EXIT trap before exiting to avoid spurious non-zero exit code.
+       exitcode=$?
+       trap '' 0
+       exit $exitcode ;;
     Alpha\ *:Windows_NT*:*)
        # How do we know it's Interix rather than the generic POSIX subsystem?
        # Should we change UNAME_MACHINE based on the output of uname instead
        # of the specific Alpha model?
        echo alpha-pc-interix
-       exit 0 ;;
+       exit ;;
     21064:Windows_NT:50:3)
        echo alpha-dec-winnt3.5
-       exit 0 ;;
+       exit ;;
     Amiga*:UNIX_System_V:4.0:*)
        echo m68k-unknown-sysv4
-       exit 0;;
+       exit ;;
     *:[Aa]miga[Oo][Ss]:*:*)
        echo ${UNAME_MACHINE}-unknown-amigaos
-       exit 0 ;;
+       exit ;;
     *:[Mm]orph[Oo][Ss]:*:*)
        echo ${UNAME_MACHINE}-unknown-morphos
-       exit 0 ;;
+       exit ;;
     *:OS/390:*:*)
        echo i370-ibm-openedition
-       exit 0 ;;
+       exit ;;
+    *:z/VM:*:*)
+       echo s390-ibm-zvmoe
+       exit ;;
     *:OS400:*:*)
-        echo powerpc-ibm-os400
-       exit 0 ;;
+       echo powerpc-ibm-os400
+       exit ;;
     arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
        echo arm-acorn-riscix${UNAME_RELEASE}
-       exit 0;;
+       exit ;;
+    arm:riscos:*:*|arm:RISCOS:*:*)
+       echo arm-unknown-riscos
+       exit ;;
     SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*)
        echo hppa1.1-hitachi-hiuxmpp
-       exit 0;;
+       exit ;;
     Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*)
        # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE.
        if test "`(/bin/universe) 2>/dev/null`" = att ; then
@@ -341,32 +317,51 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
        else
                echo pyramid-pyramid-bsd
        fi
-       exit 0 ;;
+       exit ;;
     NILE*:*:*:dcosx)
        echo pyramid-pyramid-svr4
-       exit 0 ;;
+       exit ;;
     DRS?6000:unix:4.0:6*)
        echo sparc-icl-nx6
-       exit 0 ;;
-    DRS?6000:UNIX_SV:4.2*:7*)
+       exit ;;
+    DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*)
        case `/usr/bin/uname -p` in
-           sparc) echo sparc-icl-nx7 && exit 0 ;;
+           sparc) echo sparc-icl-nx7; exit ;;
        esac ;;
+    s390x:SunOS:*:*)
+       echo ${UNAME_MACHINE}-ibm-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+       exit ;;
     sun4H:SunOS:5.*:*)
        echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
-       exit 0 ;;
+       exit ;;
     sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
        echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
-       exit 0 ;;
-    i86pc:SunOS:5.*:*)
-       echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
-       exit 0 ;;
+       exit ;;
+    i86pc:AuroraUX:5.*:* | i86xen:AuroraUX:5.*:*)
+       echo i386-pc-auroraux${UNAME_RELEASE}
+       exit ;;
+    i86pc:SunOS:5.*:* | i86xen:SunOS:5.*:*)
+       eval $set_cc_for_build
+       SUN_ARCH="i386"
+       # If there is a compiler, see if it is configured for 64-bit objects.
+       # Note that the Sun cc does not turn __LP64__ into 1 like gcc does.
+       # This test works for both compilers.
+       if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then
+           if (echo '#ifdef __amd64'; echo IS_64BIT_ARCH; echo '#endif') | \
+               (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \
+               grep IS_64BIT_ARCH >/dev/null
+           then
+               SUN_ARCH="x86_64"
+           fi
+       fi
+       echo ${SUN_ARCH}-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
+       exit ;;
     sun4*:SunOS:6*:*)
        # According to config.sub, this is the proper way to canonicalize
        # SunOS6.  Hard to guess exactly what SunOS6 will be like, but
        # it's likely to be more like Solaris than SunOS4.
        echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
-       exit 0 ;;
+       exit ;;
     sun4*:SunOS:*:*)
        case "`/usr/bin/arch -k`" in
            Series*|S4*)
@@ -375,10 +370,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
        esac
        # Japanese Language versions have a version number like `4.1.3-JL'.
        echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
-       exit 0 ;;
+       exit ;;
     sun3*:SunOS:*:*)
        echo m68k-sun-sunos${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     sun*:*:4.2BSD:*)
        UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`
        test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3
@@ -390,10 +385,10 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
                echo sparc-sun-sunos${UNAME_RELEASE}
                ;;
        esac
-       exit 0 ;;
+       exit ;;
     aushp:SunOS:*:*)
        echo sparc-auspex-sunos${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     # The situation for MiNT is a little confusing.  The machine name
     # can be virtually everything (everything which is not
     # "atarist" or "atariste" at least should have a processor
@@ -403,41 +398,41 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
     # MiNT.  But MiNT is downward compatible to TOS, so this should
     # be no problem.
     atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*)
-        echo m68k-atari-mint${UNAME_RELEASE}
-       exit 0 ;;
+       echo m68k-atari-mint${UNAME_RELEASE}
+       exit ;;
     atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*)
        echo m68k-atari-mint${UNAME_RELEASE}
-        exit 0 ;;
+       exit ;;
     *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*)
-        echo m68k-atari-mint${UNAME_RELEASE}
-       exit 0 ;;
+       echo m68k-atari-mint${UNAME_RELEASE}
+       exit ;;
     milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*)
-        echo m68k-milan-mint${UNAME_RELEASE}
-        exit 0 ;;
+       echo m68k-milan-mint${UNAME_RELEASE}
+       exit ;;
     hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*)
-        echo m68k-hades-mint${UNAME_RELEASE}
-        exit 0 ;;
+       echo m68k-hades-mint${UNAME_RELEASE}
+       exit ;;
     *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*)
-        echo m68k-unknown-mint${UNAME_RELEASE}
-        exit 0 ;;
+       echo m68k-unknown-mint${UNAME_RELEASE}
+       exit ;;
     m68k:machten:*:*)
        echo m68k-apple-machten${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     powerpc:machten:*:*)
        echo powerpc-apple-machten${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     RISC*:Mach:*:*)
        echo mips-dec-mach_bsd4.3
-       exit 0 ;;
+       exit ;;
     RISC*:ULTRIX:*:*)
        echo mips-dec-ultrix${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     VAX*:ULTRIX*:*:*)
        echo vax-dec-ultrix${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     2020:CLIX:*:* | 2430:CLIX:*:*)
        echo clipper-intergraph-clix${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     mips:*:*:UMIPS | mips:*:*:RISCos)
        eval $set_cc_for_build
        sed 's/^        //' << EOF >$dummy.c
@@ -461,35 +456,36 @@ case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
          exit (-1);
        }
 EOF
-       $CC_FOR_BUILD -o $dummy $dummy.c \
-         && $dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \
-         && exit 0
+       $CC_FOR_BUILD -o $dummy $dummy.c &&
+         dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` &&
+         SYSTEM_NAME=`$dummy $dummyarg` &&
+           { echo "$SYSTEM_NAME"; exit; }
        echo mips-mips-riscos${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     Motorola:PowerMAX_OS:*:*)
        echo powerpc-motorola-powermax
-       exit 0 ;;
+       exit ;;
     Motorola:*:4.3:PL8-*)
        echo powerpc-harris-powermax
-       exit 0 ;;
+       exit ;;
     Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*)
        echo powerpc-harris-powermax
-       exit 0 ;;
+       exit ;;
     Night_Hawk:Power_UNIX:*:*)
        echo powerpc-harris-powerunix
-       exit 0 ;;
+       exit ;;
     m88k:CX/UX:7*:*)
        echo m88k-harris-cxux7
-       exit 0 ;;
+       exit ;;
     m88k:*:4*:R4*)
        echo m88k-motorola-sysv4
-       exit 0 ;;
+       exit ;;
     m88k:*:3*:R3*)
        echo m88k-motorola-sysv3
-       exit 0 ;;
+       exit ;;
     AViiON:dgux:*:*)
-        # DG/UX returns AViiON for all architectures
-        UNAME_PROCESSOR=`/usr/bin/uname -p`
+       # DG/UX returns AViiON for all architectures
+       UNAME_PROCESSOR=`/usr/bin/uname -p`
        if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ]
        then
            if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \
@@ -502,29 +498,29 @@ EOF
        else
            echo i586-dg-dgux${UNAME_RELEASE}
        fi
-       exit 0 ;;
+       exit ;;
     M88*:DolphinOS:*:*)        # DolphinOS (SVR3)
        echo m88k-dolphin-sysv3
-       exit 0 ;;
+       exit ;;
     M88*:*:R3*:*)
        # Delta 88k system running SVR3
        echo m88k-motorola-sysv3
-       exit 0 ;;
+       exit ;;
     XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
        echo m88k-tektronix-sysv3
-       exit 0 ;;
+       exit ;;
     Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
        echo m68k-tektronix-bsd
-       exit 0 ;;
+       exit ;;
     *:IRIX*:*:*)
        echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
-       exit 0 ;;
+       exit ;;
     ????????:AIX?:[12].1:2)   # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
-       echo romp-ibm-aix      # uname -m gives an 8 hex-code CPU id
-       exit 0 ;;              # Note that: echo "'`uname -s`'" gives 'AIX '
+       echo romp-ibm-aix     # uname -m gives an 8 hex-code CPU id
+       exit ;;               # Note that: echo "'`uname -s`'" gives 'AIX '
     i*86:AIX:*:*)
        echo i386-ibm-aix
-       exit 0 ;;
+       exit ;;
     ia64:AIX:*:*)
        if [ -x /usr/bin/oslevel ] ; then
                IBM_REV=`/usr/bin/oslevel`
@@ -532,7 +528,7 @@ EOF
                IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
        fi
        echo ${UNAME_MACHINE}-ibm-aix${IBM_REV}
-       exit 0 ;;
+       exit ;;
     *:AIX:2:3)
        if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
                eval $set_cc_for_build
@@ -547,15 +543,19 @@ EOF
                        exit(0);
                        }
 EOF
-               $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0
-               echo rs6000-ibm-aix3.2.5
+               if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy`
+               then
+                       echo "$SYSTEM_NAME"
+               else
+                       echo rs6000-ibm-aix3.2.5
+               fi
        elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
                echo rs6000-ibm-aix3.2.4
        else
                echo rs6000-ibm-aix3.2
        fi
-       exit 0 ;;
-    *:AIX:*:[45])
+       exit ;;
+    *:AIX:*:[4567])
        IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'`
        if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then
                IBM_ARCH=rs6000
@@ -568,28 +568,28 @@ EOF
                IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE}
        fi
        echo ${IBM_ARCH}-ibm-aix${IBM_REV}
-       exit 0 ;;
+       exit ;;
     *:AIX:*:*)
        echo rs6000-ibm-aix
-       exit 0 ;;
+       exit ;;
     ibmrt:4.4BSD:*|romp-ibm:BSD:*)
        echo romp-ibm-bsd4.4
-       exit 0 ;;
+       exit ;;
     ibmrt:*BSD:*|romp-ibm:BSD:*)            # covers RT/PC BSD and
        echo romp-ibm-bsd${UNAME_RELEASE}   # 4.3 with uname added to
-       exit 0 ;;                           # report: romp-ibm BSD 4.3
+       exit ;;                             # report: romp-ibm BSD 4.3
     *:BOSX:*:*)
        echo rs6000-bull-bosx
-       exit 0 ;;
+       exit ;;
     DPX/2?00:B.O.S.:*:*)
        echo m68k-bull-sysv3
-       exit 0 ;;
+       exit ;;
     9000/[34]??:4.3bsd:1.*:*)
        echo m68k-hp-bsd
-       exit 0 ;;
+       exit ;;
     hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
        echo m68k-hp-bsd4.4
-       exit 0 ;;
+       exit ;;
     9000/[34678]??:HP-UX:*:*)
        HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
        case "${UNAME_MACHINE}" in
@@ -598,52 +598,52 @@ EOF
            9000/[678][0-9][0-9])
                if [ -x /usr/bin/getconf ]; then
                    sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null`
-                    sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
-                    case "${sc_cpu_version}" in
-                      523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0
-                      528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1
-                      532)                      # CPU_PA_RISC2_0
-                        case "${sc_kernel_bits}" in
-                          32) HP_ARCH="hppa2.0n" ;;
-                          64) HP_ARCH="hppa2.0w" ;;
+                   sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null`
+                   case "${sc_cpu_version}" in
+                     523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0
+                     528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1
+                     532)                      # CPU_PA_RISC2_0
+                       case "${sc_kernel_bits}" in
+                         32) HP_ARCH="hppa2.0n" ;;
+                         64) HP_ARCH="hppa2.0w" ;;
                          '') HP_ARCH="hppa2.0" ;;   # HP-UX 10.20
-                        esac ;;
-                    esac
+                       esac ;;
+                   esac
                fi
                if [ "${HP_ARCH}" = "" ]; then
                    eval $set_cc_for_build
-                   sed 's/^              //' << EOF >$dummy.c
+                   sed 's/^            //' << EOF >$dummy.c
 
-              #define _HPUX_SOURCE
-              #include <stdlib.h>
-              #include <unistd.h>
+               #define _HPUX_SOURCE
+               #include <stdlib.h>
+               #include <unistd.h>
 
-              int main ()
-              {
-              #if defined(_SC_KERNEL_BITS)
-                  long bits = sysconf(_SC_KERNEL_BITS);
-              #endif
-                  long cpu  = sysconf (_SC_CPU_VERSION);
+               int main ()
+               {
+               #if defined(_SC_KERNEL_BITS)
+                   long bits = sysconf(_SC_KERNEL_BITS);
+               #endif
+                   long cpu  = sysconf (_SC_CPU_VERSION);
 
-                  switch (cpu)
-               {
-               case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
-               case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
-               case CPU_PA_RISC2_0:
-              #if defined(_SC_KERNEL_BITS)
-                   switch (bits)
-                       {
-                       case 64: puts ("hppa2.0w"); break;
-                       case 32: puts ("hppa2.0n"); break;
-                       default: puts ("hppa2.0"); break;
-                       } break;
-              #else  /* !defined(_SC_KERNEL_BITS) */
-                   puts ("hppa2.0"); break;
-              #endif
-               default: puts ("hppa1.0"); break;
-               }
-                  exit (0);
-              }
+                   switch (cpu)
+                       {
+                       case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
+                       case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
+                       case CPU_PA_RISC2_0:
+               #if defined(_SC_KERNEL_BITS)
+                           switch (bits)
+                               {
+                               case 64: puts ("hppa2.0w"); break;
+                               case 32: puts ("hppa2.0n"); break;
+                               default: puts ("hppa2.0"); break;
+                               } break;
+               #else  /* !defined(_SC_KERNEL_BITS) */
+                           puts ("hppa2.0"); break;
+               #endif
+                       default: puts ("hppa1.0"); break;
+                       }
+                   exit (0);
+               }
 EOF
                    (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy`
                    test -z "$HP_ARCH" && HP_ARCH=hppa
@@ -651,9 +651,19 @@ EOF
        esac
        if [ ${HP_ARCH} = "hppa2.0w" ]
        then
-           # avoid double evaluation of $set_cc_for_build
-           test -n "$CC_FOR_BUILD" || eval $set_cc_for_build
-           if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E -) | grep __LP64__ >/dev/null
+           eval $set_cc_for_build
+
+           # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating
+           # 32-bit code.  hppa64-hp-hpux* has the same kernel and a compiler
+           # generating 64-bit code.  GNU and HP use different nomenclature:
+           #
+           # $ CC_FOR_BUILD=cc ./config.guess
+           # => hppa2.0w-hp-hpux11.23
+           # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess
+           # => hppa64-hp-hpux11.23
+
+           if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) |
+               grep -q __LP64__
            then
                HP_ARCH="hppa2.0w"
            else
@@ -661,11 +671,11 @@ EOF
            fi
        fi
        echo ${HP_ARCH}-hp-hpux${HPUX_REV}
-       exit 0 ;;
+       exit ;;
     ia64:HP-UX:*:*)
        HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
        echo ia64-hp-hpux${HPUX_REV}
-       exit 0 ;;
+       exit ;;
     3050*:HI-UX:*:*)
        eval $set_cc_for_build
        sed 's/^        //' << EOF >$dummy.c
@@ -693,224 +703,259 @@ EOF
          exit (0);
        }
 EOF
-       $CC_FOR_BUILD -o $dummy $dummy.c && $dummy && exit 0
+       $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` &&
+               { echo "$SYSTEM_NAME"; exit; }
        echo unknown-hitachi-hiuxwe2
-       exit 0 ;;
+       exit ;;
     9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )
        echo hppa1.1-hp-bsd
-       exit 0 ;;
+       exit ;;
     9000/8??:4.3bsd:*:*)
        echo hppa1.0-hp-bsd
-       exit 0 ;;
+       exit ;;
     *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*)
        echo hppa1.0-hp-mpeix
-       exit 0 ;;
+       exit ;;
     hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )
        echo hppa1.1-hp-osf
-       exit 0 ;;
+       exit ;;
     hp8??:OSF1:*:*)
        echo hppa1.0-hp-osf
-       exit 0 ;;
+       exit ;;
     i*86:OSF1:*:*)
        if [ -x /usr/sbin/sysversion ] ; then
            echo ${UNAME_MACHINE}-unknown-osf1mk
        else
            echo ${UNAME_MACHINE}-unknown-osf1
        fi
-       exit 0 ;;
+       exit ;;
     parisc*:Lites*:*:*)
        echo hppa1.1-hp-lites
-       exit 0 ;;
+       exit ;;
     C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
        echo c1-convex-bsd
-        exit 0 ;;
+       exit ;;
     C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
        if getsysinfo -f scalar_acc
        then echo c32-convex-bsd
        else echo c2-convex-bsd
        fi
-        exit 0 ;;
+       exit ;;
     C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
        echo c34-convex-bsd
-        exit 0 ;;
+       exit ;;
     C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
        echo c38-convex-bsd
-        exit 0 ;;
+       exit ;;
     C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
        echo c4-convex-bsd
-        exit 0 ;;
+       exit ;;
     CRAY*Y-MP:*:*:*)
        echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
-       exit 0 ;;
+       exit ;;
     CRAY*[A-Z]90:*:*:*)
        echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
        | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
              -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \
              -e 's/\.[^.]*$/.X/'
-       exit 0 ;;
+       exit ;;
     CRAY*TS:*:*:*)
        echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
-       exit 0 ;;
+       exit ;;
     CRAY*T3E:*:*:*)
        echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
-       exit 0 ;;
+       exit ;;
     CRAY*SV1:*:*:*)
        echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
-       exit 0 ;;
+       exit ;;
     *:UNICOS/mp:*:*)
-       echo nv1-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
-       exit 0 ;;
+       echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/'
+       exit ;;
     F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*)
        FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'`
-        FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
-        FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
-        echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
-        exit 0 ;;
+       FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+       FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
+       echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+       exit ;;
     5000:UNIX_System_V:4.*:*)
-        FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
-        FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`
-        echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
-       exit 0 ;;
+       FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'`
+       FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'`
+       echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
+       exit ;;
     i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*)
        echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     sparc*:BSD/OS:*:*)
        echo sparc-unknown-bsdi${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:BSD/OS:*:*)
        echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:FreeBSD:*:*)
-       # Determine whether the default compiler uses glibc.
-       eval $set_cc_for_build
-       sed 's/^        //' << EOF >$dummy.c
-       #include <features.h>
-       #if __GLIBC__ >= 2
-       LIBC=gnu
-       #else
-       LIBC=
-       #endif
-EOF
-       eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=`
-       # GNU/KFreeBSD systems have a "k" prefix to indicate we are using
-       # FreeBSD's kernel, but not the complete OS.
-       case ${LIBC} in gnu) kernel_only='k' ;; esac
-       echo ${UNAME_MACHINE}-unknown-${kernel_only}freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`${LIBC:+-$LIBC}
-       exit 0 ;;
+       UNAME_PROCESSOR=`/usr/bin/uname -p`
+       case ${UNAME_PROCESSOR} in
+           amd64)
+               echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+           *)
+               echo ${UNAME_PROCESSOR}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;;
+       esac
+       exit ;;
     i*:CYGWIN*:*)
        echo ${UNAME_MACHINE}-pc-cygwin
-       exit 0 ;;
-    i*:MINGW*:*)
+       exit ;;
+    *:MINGW*:*)
        echo ${UNAME_MACHINE}-pc-mingw32
-       exit 0 ;;
+       exit ;;
+    i*:MSYS*:*)
+       echo ${UNAME_MACHINE}-pc-msys
+       exit ;;
+    i*:windows32*:*)
+       # uname -m includes "-pc" on this system.
+       echo ${UNAME_MACHINE}-mingw32
+       exit ;;
     i*:PW*:*)
        echo ${UNAME_MACHINE}-pc-pw32
-       exit 0 ;;
-    x86:Interix*:[34]*)
-       echo i586-pc-interix${UNAME_RELEASE}|sed -e 's/\..*//'
-       exit 0 ;;
+       exit ;;
+    *:Interix*:*)
+       case ${UNAME_MACHINE} in
+           x86)
+               echo i586-pc-interix${UNAME_RELEASE}
+               exit ;;
+           authenticamd | genuineintel | EM64T)
+               echo x86_64-unknown-interix${UNAME_RELEASE}
+               exit ;;
+           IA64)
+               echo ia64-unknown-interix${UNAME_RELEASE}
+               exit ;;
+       esac ;;
     [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*)
        echo i${UNAME_MACHINE}-pc-mks
-       exit 0 ;;
+       exit ;;
+    8664:Windows_NT:*)
+       echo x86_64-pc-mks
+       exit ;;
     i*:Windows_NT*:* | Pentium*:Windows_NT*:*)
        # How do we know it's Interix rather than the generic POSIX subsystem?
        # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we
        # UNAME_MACHINE based on the output of uname instead of i386?
        echo i586-pc-interix
-       exit 0 ;;
+       exit ;;
     i*:UWIN*:*)
        echo ${UNAME_MACHINE}-pc-uwin
-       exit 0 ;;
+       exit ;;
+    amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*)
+       echo x86_64-unknown-cygwin
+       exit ;;
     p*:CYGWIN*:*)
        echo powerpcle-unknown-cygwin
-       exit 0 ;;
+       exit ;;
     prep*:SunOS:5.*:*)
        echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
-       exit 0 ;;
+       exit ;;
     *:GNU:*:*)
        # the GNU system
        echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
-       exit 0 ;;
+       exit ;;
     *:GNU/*:*:*)
        # other systems with GNU libc and userland
        echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu
-       exit 0 ;;
+       exit ;;
     i*86:Minix:*:*)
        echo ${UNAME_MACHINE}-pc-minix
-       exit 0 ;;
+       exit ;;
+    alpha:Linux:*:*)
+       case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
+         EV5)   UNAME_MACHINE=alphaev5 ;;
+         EV56)  UNAME_MACHINE=alphaev56 ;;
+         PCA56) UNAME_MACHINE=alphapca56 ;;
+         PCA57) UNAME_MACHINE=alphapca56 ;;
+         EV6)   UNAME_MACHINE=alphaev6 ;;
+         EV67)  UNAME_MACHINE=alphaev67 ;;
+         EV68*) UNAME_MACHINE=alphaev68 ;;
+       esac
+       objdump --private-headers /bin/sh | grep -q ld.so.1
+       if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi
+       echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}
+       exit ;;
     arm*:Linux:*:*)
+       eval $set_cc_for_build
+       if echo __ARM_EABI__ | $CC_FOR_BUILD -E - 2>/dev/null \
+           | grep -q __ARM_EABI__
+       then
+           echo ${UNAME_MACHINE}-unknown-linux-gnu
+       else
+           if echo __ARM_PCS_VFP | $CC_FOR_BUILD -E - 2>/dev/null \
+               | grep -q __ARM_PCS_VFP
+           then
+               echo ${UNAME_MACHINE}-unknown-linux-gnueabi
+           else
+               echo ${UNAME_MACHINE}-unknown-linux-gnueabihf
+           fi
+       fi
+       exit ;;
+    avr32*:Linux:*:*)
        echo ${UNAME_MACHINE}-unknown-linux-gnu
-       exit 0 ;;
-    sa110:Linux:*:*)
-       echo arm-unknown-linux-gnu
-       exit 0 ;;
+       exit ;;
     cris:Linux:*:*)
        echo cris-axis-linux-gnu
-       exit 0 ;;
-    ia64:Linux:*:*)
-       echo ${UNAME_MACHINE}-unknown-linux-gnu
-       exit 0 ;;
-    m68*:Linux:*:*)
-       echo ${UNAME_MACHINE}-unknown-linux-gnu
-       exit 0 ;;
-    mips:Linux:*:*)
+       exit ;;
+    crisv32:Linux:*:*)
+       echo crisv32-axis-linux-gnu
+       exit ;;
+    frv:Linux:*:*)
+       echo frv-unknown-linux-gnu
+       exit ;;
+    hexagon:Linux:*:*)
+       echo hexagon-unknown-linux-gnu
+       exit ;;
+    i*86:Linux:*:*)
+       LIBC=gnu
        eval $set_cc_for_build
        sed 's/^        //' << EOF >$dummy.c
-       #undef CPU
-       #undef mips
-       #undef mipsel
-       #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
-       CPU=mipsel
-       #else
-       #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
-       CPU=mips
-       #else
-       CPU=
-       #endif
+       #ifdef __dietlibc__
+       LIBC=dietlibc
        #endif
 EOF
-       eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=`
-       test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0
-       ;;
-    mips64:Linux:*:*)
+       eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'`
+       echo "${UNAME_MACHINE}-pc-linux-${LIBC}"
+       exit ;;
+    ia64:Linux:*:*)
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
+    m32r*:Linux:*:*)
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
+    m68*:Linux:*:*)
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
+    mips:Linux:*:* | mips64:Linux:*:*)
        eval $set_cc_for_build
        sed 's/^        //' << EOF >$dummy.c
        #undef CPU
-       #undef mips64
-       #undef mips64el
+       #undef ${UNAME_MACHINE}
+       #undef ${UNAME_MACHINE}el
        #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL)
-       CPU=mips64el
+       CPU=${UNAME_MACHINE}el
        #else
        #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB)
-       CPU=mips64
+       CPU=${UNAME_MACHINE}
        #else
        CPU=
        #endif
        #endif
 EOF
-       eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^CPU=`
-       test x"${CPU}" != x && echo "${CPU}-unknown-linux-gnu" && exit 0
+       eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'`
+       test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; }
        ;;
-    ppc:Linux:*:*)
-       echo powerpc-unknown-linux-gnu
-       exit 0 ;;
-    ppc64:Linux:*:*)
-       echo powerpc64-unknown-linux-gnu
-       exit 0 ;;
-    alpha:Linux:*:*)
-       case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in
-         EV5)   UNAME_MACHINE=alphaev5 ;;
-         EV56)  UNAME_MACHINE=alphaev56 ;;
-         PCA56) UNAME_MACHINE=alphapca56 ;;
-         PCA57) UNAME_MACHINE=alphapca56 ;;
-         EV6)   UNAME_MACHINE=alphaev6 ;;
-         EV67)  UNAME_MACHINE=alphaev67 ;;
-         EV68*) UNAME_MACHINE=alphaev68 ;;
-        esac
-       objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null
-       if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi
-       echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC}
-       exit 0 ;;
+    or32:Linux:*:*)
+       echo or32-unknown-linux-gnu
+       exit ;;
+    padre:Linux:*:*)
+       echo sparc-unknown-linux-gnu
+       exit ;;
+    parisc64:Linux:*:* | hppa64:Linux:*:*)
+       echo hppa64-unknown-linux-gnu
+       exit ;;
     parisc:Linux:*:* | hppa:Linux:*:*)
        # Look for CPU level
        case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in
@@ -918,115 +963,71 @@ EOF
          PA8*) echo hppa2.0-unknown-linux-gnu ;;
          *)    echo hppa-unknown-linux-gnu ;;
        esac
-       exit 0 ;;
-    parisc64:Linux:*:* | hppa64:Linux:*:*)
-       echo hppa64-unknown-linux-gnu
-       exit 0 ;;
+       exit ;;
+    ppc64:Linux:*:*)
+       echo powerpc64-unknown-linux-gnu
+       exit ;;
+    ppc:Linux:*:*)
+       echo powerpc-unknown-linux-gnu
+       exit ;;
     s390:Linux:*:* | s390x:Linux:*:*)
        echo ${UNAME_MACHINE}-ibm-linux
-       exit 0 ;;
+       exit ;;
     sh64*:Linux:*:*)
-       echo ${UNAME_MACHINE}-unknown-linux-gnu
-       exit 0 ;;
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
     sh*:Linux:*:*)
        echo ${UNAME_MACHINE}-unknown-linux-gnu
-       exit 0 ;;
+       exit ;;
     sparc:Linux:*:* | sparc64:Linux:*:*)
        echo ${UNAME_MACHINE}-unknown-linux-gnu
-       exit 0 ;;
+       exit ;;
+    tile*:Linux:*:*)
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
+    vax:Linux:*:*)
+       echo ${UNAME_MACHINE}-dec-linux-gnu
+       exit ;;
     x86_64:Linux:*:*)
        echo x86_64-unknown-linux-gnu
-       exit 0 ;;
-    i*86:Linux:*:*)
-       # The BFD linker knows what the default object file format is, so
-       # first see if it will tell us. cd to the root directory to prevent
-       # problems with other programs or directories called `ld' in the path.
-       # Set LC_ALL=C to ensure ld outputs messages in English.
-       ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \
-                        | sed -ne '/supported targets:/!d
-                                   s/[         ][      ]*/ /g
-                                   s/.*supported targets: *//
-                                   s/ .*//
-                                   p'`
-        case "$ld_supported_targets" in
-         elf32-i386)
-               TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu"
-               ;;
-         a.out-i386-linux)
-               echo "${UNAME_MACHINE}-pc-linux-gnuaout"
-               exit 0 ;;
-         coff-i386)
-               echo "${UNAME_MACHINE}-pc-linux-gnucoff"
-               exit 0 ;;
-         "")
-               # Either a pre-BFD a.out linker (linux-gnuoldld) or
-               # one that does not give us useful --help.
-               echo "${UNAME_MACHINE}-pc-linux-gnuoldld"
-               exit 0 ;;
-       esac
-       # Determine whether the default compiler is a.out or elf
-       eval $set_cc_for_build
-       sed 's/^        //' << EOF >$dummy.c
-       #include <features.h>
-       #ifdef __ELF__
-       # ifdef __GLIBC__
-       #  if __GLIBC__ >= 2
-       LIBC=gnu
-       #  else
-       LIBC=gnulibc1
-       #  endif
-       # else
-       LIBC=gnulibc1
-       # endif
-       #else
-       #ifdef __INTEL_COMPILER
-       LIBC=gnu
-       #else
-       LIBC=gnuaout
-       #endif
-       #endif
-       #ifdef __dietlibc__
-       LIBC=dietlibc
-       #endif
-EOF
-       eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep ^LIBC=`
-       test x"${LIBC}" != x && echo "${UNAME_MACHINE}-pc-linux-${LIBC}" && exit 0
-       test x"${TENTATIVE}" != x && echo "${TENTATIVE}" && exit 0
-       ;;
+       exit ;;
+    xtensa*:Linux:*:*)
+       echo ${UNAME_MACHINE}-unknown-linux-gnu
+       exit ;;
     i*86:DYNIX/ptx:4*:*)
        # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.
        # earlier versions are messed up and put the nodename in both
        # sysname and nodename.
        echo i386-sequent-sysv4
-       exit 0 ;;
+       exit ;;
     i*86:UNIX_SV:4.2MP:2.*)
-        # Unixware is an offshoot of SVR4, but it has its own version
-        # number series starting with 2...
-        # I am not positive that other SVR4 systems won't match this,
+       # Unixware is an offshoot of SVR4, but it has its own version
+       # number series starting with 2...
+       # I am not positive that other SVR4 systems won't match this,
        # I just have to hope.  -- rms.
-        # Use sysv4.2uw... so that sysv4* matches it.
+       # Use sysv4.2uw... so that sysv4* matches it.
        echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
-       exit 0 ;;
+       exit ;;
     i*86:OS/2:*:*)
        # If we were able to find `uname', then EMX Unix compatibility
        # is probably installed.
        echo ${UNAME_MACHINE}-pc-os2-emx
-       exit 0 ;;
+       exit ;;
     i*86:XTS-300:*:STOP)
        echo ${UNAME_MACHINE}-unknown-stop
-       exit 0 ;;
+       exit ;;
     i*86:atheos:*:*)
        echo ${UNAME_MACHINE}-unknown-atheos
-       exit 0 ;;
-       i*86:syllable:*:*)
+       exit ;;
+    i*86:syllable:*:*)
        echo ${UNAME_MACHINE}-pc-syllable
-       exit 0 ;;
-    i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*)
+       exit ;;
+    i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.[02]*:*)
        echo i386-unknown-lynxos${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     i*86:*DOS:*:*)
        echo ${UNAME_MACHINE}-pc-msdosdjgpp
-       exit 0 ;;
+       exit ;;
     i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*)
        UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'`
        if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
@@ -1034,15 +1035,16 @@ EOF
        else
                echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL}
        fi
-       exit 0 ;;
-    i*86:*:5:[78]*)
+       exit ;;
+    i*86:*:5:[678]*)
+       # UnixWare 7.x, OpenUNIX and OpenServer 6.
        case `/bin/uname -X | grep "^Machine"` in
            *486*)           UNAME_MACHINE=i486 ;;
            *Pentium)        UNAME_MACHINE=i586 ;;
            *Pent*|*Celeron) UNAME_MACHINE=i686 ;;
        esac
        echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION}
-       exit 0 ;;
+       exit ;;
     i*86:*:3.2:*)
        if test -f /usr/options/cb.name; then
                UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
@@ -1060,73 +1062,86 @@ EOF
        else
                echo ${UNAME_MACHINE}-pc-sysv32
        fi
-       exit 0 ;;
+       exit ;;
     pc:*:*:*)
        # Left here for compatibility:
-        # uname -m prints for DJGPP always 'pc', but it prints nothing about
-        # the processor, so we play safe by assuming i386.
-       echo i386-pc-msdosdjgpp
-        exit 0 ;;
+       # uname -m prints for DJGPP always 'pc', but it prints nothing about
+       # the processor, so we play safe by assuming i586.
+       # Note: whatever this is, it MUST be the same as what config.sub
+       # prints for the "djgpp" host, or else GDB configury will decide that
+       # this is a cross-build.
+       echo i586-pc-msdosdjgpp
+       exit ;;
     Intel:Mach:3*:*)
        echo i386-pc-mach3
-       exit 0 ;;
+       exit ;;
     paragon:*:*:*)
        echo i860-intel-osf1
-       exit 0 ;;
+       exit ;;
     i860:*:4.*:*) # i860-SVR4
        if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
          echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
        else # Add other i860-SVR4 vendors below as they are discovered.
          echo i860-unknown-sysv${UNAME_RELEASE}  # Unknown i860-SVR4
        fi
-       exit 0 ;;
+       exit ;;
     mini*:CTIX:SYS*5:*)
        # "miniframe"
        echo m68010-convergent-sysv
-       exit 0 ;;
+       exit ;;
     mc68k:UNIX:SYSTEM5:3.51m)
        echo m68k-convergent-sysv
-       exit 0 ;;
+       exit ;;
     M680?0:D-NIX:5.3:*)
        echo m68k-diab-dnix
-       exit 0 ;;
-    M68*:*:R3V[567]*:*)
-       test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;;
-    3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0)
+       exit ;;
+    M68*:*:R3V[5678]*:*)
+       test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;;
+    3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0)
        OS_REL=''
        test -r /etc/.relid \
        && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
        /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
-         && echo i486-ncr-sysv4.3${OS_REL} && exit 0
+         && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
        /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
-         && echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;;
+         && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
     3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
-        /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
-          && echo i486-ncr-sysv4 && exit 0 ;;
+       /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+         && { echo i486-ncr-sysv4; exit; } ;;
+    NCR*:*:4.2:* | MPRAS*:*:4.2:*)
+       OS_REL='.3'
+       test -r /etc/.relid \
+           && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
+       /bin/uname -p 2>/dev/null | grep 86 >/dev/null \
+           && { echo i486-ncr-sysv4.3${OS_REL}; exit; }
+       /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
+           && { echo i586-ncr-sysv4.3${OS_REL}; exit; }
+       /bin/uname -p 2>/dev/null | /bin/grep pteron >/dev/null \
+           && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;;
     m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*)
        echo m68k-unknown-lynxos${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     mc68030:UNIX_System_V:4.*:*)
        echo m68k-atari-sysv4
-       exit 0 ;;
+       exit ;;
     TSUNAMI:LynxOS:2.*:*)
        echo sparc-unknown-lynxos${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     rs6000:LynxOS:2.*:*)
        echo rs6000-unknown-lynxos${UNAME_RELEASE}
-       exit 0 ;;
-    PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*)
+       exit ;;
+    PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.[02]*:*)
        echo powerpc-unknown-lynxos${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     SM[BE]S:UNIX_SV:*:*)
        echo mips-dde-sysv${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     RM*:ReliantUNIX-*:*:*)
        echo mips-sni-sysv4
-       exit 0 ;;
+       exit ;;
     RM*:SINIX-*:*:*)
        echo mips-sni-sysv4
-       exit 0 ;;
+       exit ;;
     *:SINIX-*:*:*)
        if uname -p 2>/dev/null >/dev/null ; then
                UNAME_MACHINE=`(uname -p) 2>/dev/null`
@@ -1134,71 +1149,94 @@ EOF
        else
                echo ns32k-sni-sysv
        fi
-       exit 0 ;;
-    PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
-                      # says <Richard.M.Bartel@ccMail.Census.GOV>
-        echo i586-unisys-sysv4
-        exit 0 ;;
+       exit ;;
+    PENTIUM:*:4.0*:*)  # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
+                       # says <Richard.M.Bartel@ccMail.Census.GOV>
+       echo i586-unisys-sysv4
+       exit ;;
     *:UNIX_System_V:4*:FTX*)
        # From Gerald Hewes <hewes@openmarket.com>.
        # How about differentiating between stratus architectures? -djm
        echo hppa1.1-stratus-sysv4
-       exit 0 ;;
+       exit ;;
     *:*:*:FTX*)
        # From seanf@swdc.stratus.com.
        echo i860-stratus-sysv4
-       exit 0 ;;
+       exit ;;
+    i*86:VOS:*:*)
+       # From Paul.Green@stratus.com.
+       echo ${UNAME_MACHINE}-stratus-vos
+       exit ;;
     *:VOS:*:*)
        # From Paul.Green@stratus.com.
        echo hppa1.1-stratus-vos
-       exit 0 ;;
+       exit ;;
     mc68*:A/UX:*:*)
        echo m68k-apple-aux${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     news*:NEWS-OS:6*:*)
        echo mips-sony-newsos6
-       exit 0 ;;
+       exit ;;
     R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*)
        if [ -d /usr/nec ]; then
-               echo mips-nec-sysv${UNAME_RELEASE}
+               echo mips-nec-sysv${UNAME_RELEASE}
        else
-               echo mips-unknown-sysv${UNAME_RELEASE}
+               echo mips-unknown-sysv${UNAME_RELEASE}
        fi
-        exit 0 ;;
+       exit ;;
     BeBox:BeOS:*:*)    # BeOS running on hardware made by Be, PPC only.
        echo powerpc-be-beos
-       exit 0 ;;
+       exit ;;
     BeMac:BeOS:*:*)    # BeOS running on Mac or Mac clone, PPC only.
        echo powerpc-apple-beos
-       exit 0 ;;
+       exit ;;
     BePC:BeOS:*:*)     # BeOS running on Intel PC compatible.
        echo i586-pc-beos
-       exit 0 ;;
+       exit ;;
+    BePC:Haiku:*:*)    # Haiku running on Intel PC compatible.
+       echo i586-pc-haiku
+       exit ;;
     SX-4:SUPER-UX:*:*)
        echo sx4-nec-superux${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     SX-5:SUPER-UX:*:*)
        echo sx5-nec-superux${UNAME_RELEASE}
-       exit 0 ;;
-    osfmach3_ppc:*:*:*)
-        echo powerpc-unknown-linux
-        exit 0 ;;
+       exit ;;
     SX-6:SUPER-UX:*:*)
        echo sx6-nec-superux${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
+    SX-7:SUPER-UX:*:*)
+       echo sx7-nec-superux${UNAME_RELEASE}
+       exit ;;
+    SX-8:SUPER-UX:*:*)
+       echo sx8-nec-superux${UNAME_RELEASE}
+       exit ;;
+    SX-8R:SUPER-UX:*:*)
+       echo sx8r-nec-superux${UNAME_RELEASE}
+       exit ;;
     Power*:Rhapsody:*:*)
        echo powerpc-apple-rhapsody${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:Rhapsody:*:*)
        echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:Darwin:*:*)
-       case `uname -p` in
-           *86) UNAME_PROCESSOR=i686 ;;
-           powerpc) UNAME_PROCESSOR=powerpc ;;
+       UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown
+       case $UNAME_PROCESSOR in
+           i386)
+               eval $set_cc_for_build
+               if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then
+                 if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \
+                     (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \
+                     grep IS_64BIT_ARCH >/dev/null
+                 then
+                     UNAME_PROCESSOR="x86_64"
+                 fi
+               fi ;;
+           unknown) UNAME_PROCESSOR=powerpc ;;
        esac
        echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:procnto*:*:* | *:QNX:[0123456789]*:*)
        UNAME_PROCESSOR=`uname -p`
        if test "$UNAME_PROCESSOR" = "x86"; then
@@ -1206,22 +1244,28 @@ EOF
                UNAME_MACHINE=pc
        fi
        echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:QNX:*:4*)
        echo i386-pc-qnx
-       exit 0 ;;
+       exit ;;
+    NEO-?:NONSTOP_KERNEL:*:*)
+       echo neo-tandem-nsk${UNAME_RELEASE}
+       exit ;;
+    NSE-?:NONSTOP_KERNEL:*:*)
+       echo nse-tandem-nsk${UNAME_RELEASE}
+       exit ;;
     NSR-?:NONSTOP_KERNEL:*:*)
        echo nsr-tandem-nsk${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:NonStop-UX:*:*)
        echo mips-compaq-nonstopux
-       exit 0 ;;
+       exit ;;
     BS2000:POSIX*:*:*)
        echo bs2000-siemens-sysv
-       exit 0 ;;
+       exit ;;
     DS/*:UNIX_System_V:*:*)
        echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE}
-       exit 0 ;;
+       exit ;;
     *:Plan9:*:*)
        # "uname -m" is not consistent, so use $cputype instead. 386
        # is converted to i386 for consistency with other x86
@@ -1232,31 +1276,50 @@ EOF
            UNAME_MACHINE="$cputype"
        fi
        echo ${UNAME_MACHINE}-unknown-plan9
-       exit 0 ;;
+       exit ;;
     *:TOPS-10:*:*)
        echo pdp10-unknown-tops10
-       exit 0 ;;
+       exit ;;
     *:TENEX:*:*)
        echo pdp10-unknown-tenex
-       exit 0 ;;
+       exit ;;
     KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*)
        echo pdp10-dec-tops20
-       exit 0 ;;
+       exit ;;
     XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*)
        echo pdp10-xkl-tops20
-       exit 0 ;;
+       exit ;;
     *:TOPS-20:*:*)
        echo pdp10-unknown-tops20
-       exit 0 ;;
+       exit ;;
     *:ITS:*:*)
        echo pdp10-unknown-its
-       exit 0 ;;
+       exit ;;
     SEI:*:*:SEIUX)
-        echo mips-sei-seiux${UNAME_RELEASE}
-       exit 0 ;;
+       echo mips-sei-seiux${UNAME_RELEASE}
+       exit ;;
     *:DragonFly:*:*)
        echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
-       exit 0 ;;
+       exit ;;
+    *:*VMS:*:*)
+       UNAME_MACHINE=`(uname -p) 2>/dev/null`
+       case "${UNAME_MACHINE}" in
+           A*) echo alpha-dec-vms ; exit ;;
+           I*) echo ia64-dec-vms ; exit ;;
+           V*) echo vax-dec-vms ; exit ;;
+       esac ;;
+    *:XENIX:*:SysV)
+       echo i386-pc-xenix
+       exit ;;
+    i*86:skyos:*:*)
+       echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//'
+       exit ;;
+    i*86:rdos:*:*)
+       echo ${UNAME_MACHINE}-pc-rdos
+       exit ;;
+    i*86:AROS:*:*)
+       echo ${UNAME_MACHINE}-pc-aros
+       exit ;;
 esac
 
 #echo '(No uname command or uname output not recognized.)' 1>&2
@@ -1279,16 +1342,16 @@ main ()
 #include <sys/param.h>
   printf ("m68k-sony-newsos%s\n",
 #ifdef NEWSOS4
-          "4"
+       "4"
 #else
-         ""
+       ""
 #endif
-         ); exit (0);
+       ); exit (0);
 #endif
 #endif
 
 #if defined (__arm) && defined (__acorn) && defined (__unix)
-  printf ("arm-acorn-riscix"); exit (0);
+  printf ("arm-acorn-riscix\n"); exit (0);
 #endif
 
 #if defined (hp300) && !defined (hpux)
@@ -1296,16 +1359,15 @@ main ()
 #endif
 
 #if defined (NeXT)
-  char * arch;
-  int version;
 #if !defined (__ARCHITECTURE__)
-  arch = "m68k";
-#else
-  arch = __ARCHITECTURE__;
-  if (strcmp(arch, "hppa") == 0) arch = "hppa1.1";
+#define __ARCHITECTURE__ "m68k"
 #endif
+  int version;
   version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
-  printf ("%s-next-nextstep%d\n", arch, version);
+  if (version < 4)
+    printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);
+  else
+    printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);
   exit (0);
 #endif
 
@@ -1378,11 +1440,12 @@ main ()
 }
 EOF
 
-$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && $dummy && exit 0
+$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` &&
+       { echo "$SYSTEM_NAME"; exit; }
 
 # Apollos put the system type in the environment.
 
-test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; }
+test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; }
 
 # Convex versions that predate uname can use getsysinfo(1)
 
@@ -1391,22 +1454,22 @@ then
     case `getsysinfo -f cpu_type` in
     c1*)
        echo c1-convex-bsd
-       exit 0 ;;
+       exit ;;
     c2*)
        if getsysinfo -f scalar_acc
        then echo c32-convex-bsd
        else echo c2-convex-bsd
        fi
-       exit 0 ;;
+       exit ;;
     c34*)
        echo c34-convex-bsd
-       exit 0 ;;
+       exit ;;
     c38*)
        echo c38-convex-bsd
-       exit 0 ;;
+       exit ;;
     c4*)
        echo c4-convex-bsd
-       exit 0 ;;
+       exit ;;
     esac
 fi
 
@@ -1417,7 +1480,9 @@ This script, last modified $timestamp, has failed to recognize
 the operating system you are using. It is advised that you
 download the most up to date version of the config scripts from
 
-    ftp://ftp.gnu.org/pub/gnu/config/
+  http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess;hb=HEAD
+and
+  http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD
 
 If the version you run ($0) is already up to date, please
 send the following data and any information you think might be

diff --git a/config/gnu/config.sub b/config/gnu/config.sub
index d2e3557ac405b653cb191fc691901219b6e8abd3..e76eaf472a84031e61b09d1c6ea5b14858b432d7 100755 (executable)
--- a/config/gnu/config.sub
+++ b/config/gnu/config.sub
@@ -1,9 +1,10 @@
 #! /bin/sh
 # Configuration validation subroutine script.
 #   Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
-#   2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+#   2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+#   2011 Free Software Foundation, Inc.
 
-timestamp='2004-02-16'
+timestamp='2011-11-11'
 
 # This file is (in principle) common to ALL GNU software.
 # The presence of a machine in this file suggests that SOME GNU software
@@ -21,22 +22,26 @@ timestamp='2004-02-16'
 #
 # You should have received a copy of the GNU General Public License
 # along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330,
-# Boston, MA 02111-1307, USA.
-
+# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA
+# 02110-1301, USA.
+#
 # As a special exception to the GNU General Public License, if you
 # distribute this file as part of a program that contains a
 # configuration script generated by Autoconf, you may include it under
 # the same distribution terms that you use for the rest of that program.
 
+
 # Please send patches to <config-patches@gnu.org>.  Submit a context
-# diff and a properly formatted ChangeLog entry.
+# diff and a properly formatted GNU ChangeLog entry.
 #
 # Configuration subroutine to validate and canonicalize a configuration type.
 # Supply the specified configuration type as an argument.
 # If it is invalid, we print an error message on stderr and exit with code 1.
 # Otherwise, we print the canonical config type on stdout and succeed.
 
+# You can get the latest version of this script from:
+# http://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub;hb=HEAD
+
 # This file is supposed to be the same for all GNU packages
 # and recognize all the CPU types, system types and aliases
 # that are meaningful with *any* GNU software.
@@ -70,8 +75,9 @@ Report bugs and patches to <config-patches@gnu.org>."
 version="\
 GNU config.sub ($timestamp)
 
-Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
-Free Software Foundation, Inc.
+Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free
+Software Foundation, Inc.
 
 This is free software; see the source for copying conditions.  There is NO
 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
@@ -83,11 +89,11 @@ Try \`$me --help' for more information."
 while test $# -gt 0 ; do
   case $1 in
     --time-stamp | --time* | -t )
-       echo "$timestamp" ; exit 0 ;;
+       echo "$timestamp" ; exit ;;
     --version | -v )
-       echo "$version" ; exit 0 ;;
+       echo "$version" ; exit ;;
     --help | --h* | -h )
-       echo "$usage"; exit 0 ;;
+       echo "$usage"; exit ;;
     -- )     # Stop option processing
        shift; break ;;
     - )        # Use stdin as input.
@@ -99,7 +105,7 @@ while test $# -gt 0 ; do
     *local*)
        # First pass through any local machine types.
        echo $1
-       exit 0;;
+       exit ;;
 
     * )
        break ;;
@@ -118,8 +124,11 @@ esac
 # Here we must recognize all the valid KERNEL-OS combinations.
 maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
 case $maybe_os in
-  nto-qnx* | linux-gnu* | linux-dietlibc | linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | \
-  kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*)
+  nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc | linux-newlib* | \
+  linux-uclibc* | uclinux-uclibc* | uclinux-gnu* | kfreebsd*-gnu* | \
+  knetbsd*-gnu* | netbsd*-gnu* | \
+  kopensolaris*-gnu* | \
+  storm-chaos* | os2-emx* | rtmk-nova*)
     os=-$maybe_os
     basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
     ;;
@@ -145,10 +154,13 @@ case $os in
        -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
        -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
        -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
-       -apple | -axis)
+       -apple | -axis | -knuth | -cray | -microblaze)
                os=
                basic_machine=$1
                ;;
+       -bluegene*)
+               os=-cnk
+               ;;
        -sim | -cisco | -oki | -wec | -winbond)
                os=
                basic_machine=$1
@@ -163,13 +175,17 @@ case $os in
                os=-chorusos
                basic_machine=$1
                ;;
-       -chorusrdb)
-               os=-chorusrdb
+       -chorusrdb)
+               os=-chorusrdb
                basic_machine=$1
-               ;;
+               ;;
        -hiux*)
                os=-hiuxwe2
                ;;
+       -sco6)
+               os=-sco5v6
+               basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+               ;;
        -sco5)
                os=-sco3.2v5
                basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
@@ -186,6 +202,10 @@ case $os in
                # Don't forget version if it is 3.2v4 or newer.
                basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
                ;;
+       -sco5v6*)
+               # Don't forget version if it is 3.2v4 or newer.
+               basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
+               ;;
        -sco*)
                os=-sco3.2v2
                basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
@@ -230,22 +250,32 @@ case $basic_machine in
        | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \
        | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \
        | am33_2.0 \
-       | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \
+       | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr | avr32 \
+        | be32 | be64 \
+       | bfin \
        | c4x | clipper \
        | d10v | d30v | dlx | dsp16xx \
-       | fr30 | frv \
+       | epiphany \
+       | fido | fr30 | frv \
        | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \
+       | hexagon \
        | i370 | i860 | i960 | ia64 \
        | ip2k | iq2000 \
-       | m32r | m68000 | m68k | m88k | mcore \
+       | le32 | le64 \
+       | lm32 \
+       | m32c | m32r | m32rle | m68000 | m68k | m88k \
+       | maxq | mb | microblaze | mcore | mep | metag \
        | mips | mipsbe | mipseb | mipsel | mipsle \
        | mips16 \
        | mips64 | mips64el \
-       | mips64vr | mips64vrel \
+       | mips64octeon | mips64octeonel \
        | mips64orion | mips64orionel \
+       | mips64r5900 | mips64r5900el \
+       | mips64vr | mips64vrel \
        | mips64vr4100 | mips64vr4100el \
        | mips64vr4300 | mips64vr4300el \
        | mips64vr5000 | mips64vr5000el \
+       | mips64vr5900 | mips64vr5900el \
        | mipsisa32 | mipsisa32el \
        | mipsisa32r2 | mipsisa32r2el \
        | mipsisa64 | mipsisa64el \
@@ -254,30 +284,63 @@ case $basic_machine in
        | mipsisa64sr71k | mipsisa64sr71kel \
        | mipstx39 | mipstx39el \
        | mn10200 | mn10300 \
+       | moxie \
+       | mt \
        | msp430 \
+       | nds32 | nds32le | nds32be \
+       | nios | nios2 \
        | ns16k | ns32k \
-       | openrisc | or32 \
+       | open8 \
+       | or32 \
        | pdp10 | pdp11 | pj | pjl \
-       | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \
+       | powerpc | powerpc64 | powerpc64le | powerpcle \
        | pyramid \
-       | sh | sh[1234] | sh[23]e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \
+       | rl78 | rx \
+       | score \
+       | sh | sh[1234] | sh[24]a | sh[24]aeb | sh[23]e | sh[34]eb | sheb | shbe | shle | sh[1234]le | sh3ele \
        | sh64 | sh64le \
-       | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \
-       | strongarm \
-       | tahoe | thumb | tic4x | tic80 | tron \
-       | v850 | v850e \
+       | sparc | sparc64 | sparc64b | sparc64v | sparc86x | sparclet | sparclite \
+       | sparcv8 | sparcv9 | sparcv9b | sparcv9v \
+       | spu \
+       | tahoe | tic4x | tic54x | tic55x | tic6x | tic80 | tron \
+       | ubicom32 \
+       | v850 | v850e | v850e1 | v850e2 | v850es | v850e2v3 \
        | we32k \
-       | x86 | xscale | xstormy16 | xtensa \
-       | z8k)
+       | x86 | xc16x | xstormy16 | xtensa \
+       | z8k | z80)
                basic_machine=$basic_machine-unknown
                ;;
-       m6811 | m68hc11 | m6812 | m68hc12)
+       c54x)
+               basic_machine=tic54x-unknown
+               ;;
+       c55x)
+               basic_machine=tic55x-unknown
+               ;;
+       c6x)
+               basic_machine=tic6x-unknown
+               ;;
+       m6811 | m68hc11 | m6812 | m68hc12 | picochip)
                # Motorola 68HC11/12.
                basic_machine=$basic_machine-unknown
                os=-none
                ;;
        m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k)
                ;;
+       ms1)
+               basic_machine=mt-unknown
+               ;;
+
+       strongarm | thumb | xscale)
+               basic_machine=arm-unknown
+               ;;
+
+       xscaleeb)
+               basic_machine=armeb-unknown
+               ;;
+
+       xscaleel)
+               basic_machine=armel-unknown
+               ;;
 
        # We use `pc' rather than `unknown'
        # because (1) that's what they normally are, and
@@ -297,28 +360,35 @@ case $basic_machine in
        | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \
        | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \
        | arm-*  | armbe-* | armle-* | armeb-* | armv*-* \
-       | avr-* \
-       | bs2000-* \
-       | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* | c55x-* | c6x-* \
-       | clipper-* | cydra-* \
+       | avr-* | avr32-* \
+       | be32-* | be64-* \
+       | bfin-* | bs2000-* \
+       | c[123]* | c30-* | [cjt]90-* | c4x-* \
+       | clipper-* | craynv-* | cydra-* \
        | d10v-* | d30v-* | dlx-* \
        | elxsi-* \
-       | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \
+       | f30[01]-* | f700-* | fido-* | fr30-* | frv-* | fx80-* \
        | h8300-* | h8500-* \
        | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \
+       | hexagon-* \
        | i*86-* | i860-* | i960-* | ia64-* \
        | ip2k-* | iq2000-* \
-       | m32r-* \
+       | le32-* | le64-* \
+       | lm32-* \
+       | m32c-* | m32r-* | m32rle-* \
        | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \
-       | m88110-* | m88k-* | mcore-* \
+       | m88110-* | m88k-* | maxq-* | mcore-* | metag-* | microblaze-* \
        | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \
        | mips16-* \
        | mips64-* | mips64el-* \
-       | mips64vr-* | mips64vrel-* \
+       | mips64octeon-* | mips64octeonel-* \
        | mips64orion-* | mips64orionel-* \
+       | mips64r5900-* | mips64r5900el-* \
+       | mips64vr-* | mips64vrel-* \
        | mips64vr4100-* | mips64vr4100el-* \
        | mips64vr4300-* | mips64vr4300el-* \
        | mips64vr5000-* | mips64vr5000el-* \
+       | mips64vr5900-* | mips64vr5900el-* \
        | mipsisa32-* | mipsisa32el-* \
        | mipsisa32r2-* | mipsisa32r2el-* \
        | mipsisa64-* | mipsisa64el-* \
@@ -326,26 +396,39 @@ case $basic_machine in
        | mipsisa64sb1-* | mipsisa64sb1el-* \
        | mipsisa64sr71k-* | mipsisa64sr71kel-* \
        | mipstx39-* | mipstx39el-* \
+       | mmix-* \
+       | mt-* \
        | msp430-* \
-       | none-* | np1-* | nv1-* | ns16k-* | ns32k-* \
+       | nds32-* | nds32le-* | nds32be-* \
+       | nios-* | nios2-* \
+       | none-* | np1-* | ns16k-* | ns32k-* \
+       | open8-* \
        | orion-* \
        | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \
-       | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \
+       | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \
        | pyramid-* \
-       | romp-* | rs6000-* \
-       | sh-* | sh[1234]-* | sh[23]e-* | sh[34]eb-* | shbe-* \
+       | rl78-* | romp-* | rs6000-* | rx-* \
+       | sh-* | sh[1234]-* | sh[24]a-* | sh[24]aeb-* | sh[23]e-* | sh[34]eb-* | sheb-* | shbe-* \
        | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \
-       | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \
-       | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \
-       | tahoe-* | thumb-* \
+       | sparc-* | sparc64-* | sparc64b-* | sparc64v-* | sparc86x-* | sparclet-* \
+       | sparclite-* \
+       | sparcv8-* | sparcv9-* | sparcv9b-* | sparcv9v-* | sv1-* | sx?-* \
+       | tahoe-* \
        | tic30-* | tic4x-* | tic54x-* | tic55x-* | tic6x-* | tic80-* \
+       | tile*-* \
        | tron-* \
-       | v850-* | v850e-* | vax-* \
+       | ubicom32-* \
+       | v850-* | v850e-* | v850e1-* | v850es-* | v850e2-* | v850e2v3-* \
+       | vax-* \
        | we32k-* \
-       | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \
-       | xtensa-* \
+       | x86-* | x86_64-* | xc16x-* | xps100-* \
+       | xstormy16-* | xtensa*-* \
        | ymp-* \
-       | z8k-*)
+       | z8k-* | z80-*)
+               ;;
+       # Recognize the basic CPU types without company name, with glob match.
+       xtensa*)
+               basic_machine=$basic_machine-unknown
                ;;
        # Recognize the various machine names and aliases which stand
        # for a CPU type and a company and sometimes even an OS.
@@ -363,7 +446,7 @@ case $basic_machine in
                basic_machine=a29k-amd
                os=-udi
                ;;
-       abacus)
+       abacus)
                basic_machine=abacus-unknown
                ;;
        adobe68k)
@@ -409,6 +492,10 @@ case $basic_machine in
                basic_machine=m68k-apollo
                os=-bsd
                ;;
+       aros)
+               basic_machine=i386-pc
+               os=-aros
+               ;;
        aux)
                basic_machine=m68k-apple
                os=-aux
@@ -417,10 +504,35 @@ case $basic_machine in
                basic_machine=ns32k-sequent
                os=-dynix
                ;;
+       blackfin)
+               basic_machine=bfin-unknown
+               os=-linux
+               ;;
+       blackfin-*)
+               basic_machine=bfin-`echo $basic_machine | sed 's/^[^-]*-//'`
+               os=-linux
+               ;;
+       bluegene*)
+               basic_machine=powerpc-ibm
+               os=-cnk
+               ;;
+       c54x-*)
+               basic_machine=tic54x-`echo $basic_machine | sed 's/^[^-]*-//'`
+               ;;
+       c55x-*)
+               basic_machine=tic55x-`echo $basic_machine | sed 's/^[^-]*-//'`
+               ;;
+       c6x-*)
+               basic_machine=tic6x-`echo $basic_machine | sed 's/^[^-]*-//'`
+               ;;
        c90)
                basic_machine=c90-cray
                os=-unicos
                ;;
+       cegcc)
+               basic_machine=arm-unknown
+               os=-cegcc
+               ;;
        convex-c1)
                basic_machine=c1-convex
                os=-bsd
@@ -445,16 +557,27 @@ case $basic_machine in
                basic_machine=j90-cray
                os=-unicos
                ;;
-       cr16c)
-               basic_machine=cr16c-unknown
+       craynv)
+               basic_machine=craynv-cray
+               os=-unicosmp
+               ;;
+       cr16 | cr16-*)
+               basic_machine=cr16-unknown
                os=-elf
                ;;
        crds | unos)
                basic_machine=m68k-crds
                ;;
+       crisv32 | crisv32-* | etraxfs*)
+               basic_machine=crisv32-axis
+               ;;
        cris | cris-* | etrax*)
                basic_machine=cris-axis
                ;;
+       crx)
+               basic_machine=crx-unknown
+               os=-elf
+               ;;
        da30 | da30-*)
                basic_machine=m68k-da30
                ;;
@@ -477,6 +600,14 @@ case $basic_machine in
                basic_machine=m88k-motorola
                os=-sysv3
                ;;
+       dicos)
+               basic_machine=i686-pc
+               os=-dicos
+               ;;
+       djgpp)
+               basic_machine=i586-pc
+               os=-msdosdjgpp
+               ;;
        dpx20 | dpx20-*)
                basic_machine=rs6000-bull
                os=-bosx
@@ -627,6 +758,14 @@ case $basic_machine in
                basic_machine=m68k-isi
                os=-sysv
                ;;
+       m68knommu)
+               basic_machine=m68k-unknown
+               os=-linux
+               ;;
+       m68knommu-*)
+               basic_machine=m68k-`echo $basic_machine | sed 's/^[^-]*-//'`
+               os=-linux
+               ;;
        m88k-omron*)
                basic_machine=m88k-omron
                ;;
@@ -638,10 +777,17 @@ case $basic_machine in
                basic_machine=ns32k-utek
                os=-sysv
                ;;
+       microblaze)
+               basic_machine=microblaze-xilinx
+               ;;
        mingw32)
                basic_machine=i386-pc
                os=-mingw32
                ;;
+       mingw32ce)
+               basic_machine=arm-unknown
+               os=-mingw32ce
+               ;;
        miniframe)
                basic_machine=m68000-convergent
                ;;
@@ -655,10 +801,6 @@ case $basic_machine in
        mips3*)
                basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
                ;;
-       mmix*)
-               basic_machine=mmix-knuth
-               os=-mmixware
-               ;;
        monitor)
                basic_machine=m68k-rom68k
                os=-coff
@@ -671,10 +813,21 @@ case $basic_machine in
                basic_machine=i386-pc
                os=-msdos
                ;;
+       ms1-*)
+               basic_machine=`echo $basic_machine | sed -e 's/ms1-/mt-/'`
+               ;;
+       msys)
+               basic_machine=i386-pc
+               os=-msys
+               ;;
        mvs)
                basic_machine=i370-ibm
                os=-mvs
                ;;
+       nacl)
+               basic_machine=le32-unknown
+               os=-nacl
+               ;;
        ncr3000)
                basic_machine=i486-ncr
                os=-sysv4
@@ -739,9 +892,11 @@ case $basic_machine in
        np1)
                basic_machine=np1-gould
                ;;
-       nv1)
-               basic_machine=nv1-cray
-               os=-unicosmp
+       neo-tandem)
+               basic_machine=neo-tandem
+               ;;
+       nse-tandem)
+               basic_machine=nse-tandem
                ;;
        nsr-tandem)
                basic_machine=nsr-tandem
@@ -750,9 +905,8 @@ case $basic_machine in
                basic_machine=hppa1.1-oki
                os=-proelf
                ;;
-       or32 | or32-*)
+       openrisc | openrisc-*)
                basic_machine=or32-unknown
-               os=-coff
                ;;
        os400)
                basic_machine=powerpc-ibm
@@ -774,6 +928,14 @@ case $basic_machine in
                basic_machine=i860-intel
                os=-osf
                ;;
+       parisc)
+               basic_machine=hppa-unknown
+               os=-linux
+               ;;
+       parisc-*)
+               basic_machine=hppa-`echo $basic_machine | sed 's/^[^-]*-//'`
+               os=-linux
+               ;;
        pbd)
                basic_machine=sparc-tti
                ;;
@@ -783,6 +945,12 @@ case $basic_machine in
        pc532 | pc532-*)
                basic_machine=ns32k-pc532
                ;;
+       pc98)
+               basic_machine=i386-pc
+               ;;
+       pc98-*)
+               basic_machine=i386-`echo $basic_machine | sed 's/^[^-]*-//'`
+               ;;
        pentium | p5 | k5 | k6 | nexgen | viac3)
                basic_machine=i586-pc
                ;;
@@ -812,9 +980,10 @@ case $basic_machine in
                ;;
        power)  basic_machine=power-ibm
                ;;
-       ppc)    basic_machine=powerpc-unknown
+       ppc | ppcbe)    basic_machine=powerpc-unknown
                ;;
-       ppc-*)  basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
+       ppc-* | ppcbe-*)
+               basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
                ;;
        ppcle | powerpclittle | ppc-le | powerpc-little)
                basic_machine=powerpcle-unknown
@@ -839,6 +1008,10 @@ case $basic_machine in
                basic_machine=i586-unknown
                os=-pw32
                ;;
+       rdos)
+               basic_machine=i386-pc
+               os=-rdos
+               ;;
        rom68k)
                basic_machine=m68k-rom68k
                os=-coff
@@ -865,6 +1038,10 @@ case $basic_machine in
        sb1el)
                basic_machine=mipsisa64sb1el-unknown
                ;;
+       sde)
+               basic_machine=mipsisa32-sde
+               os=-elf
+               ;;
        sei)
                basic_machine=mips-sei
                os=-seiux
@@ -876,6 +1053,9 @@ case $basic_machine in
                basic_machine=sh-hitachi
                os=-hms
                ;;
+       sh5el)
+               basic_machine=sh5le-unknown
+               ;;
        sh64)
                basic_machine=sh64-unknown
                ;;
@@ -897,6 +1077,9 @@ case $basic_machine in
                basic_machine=i860-stratus
                os=-sysv4
                ;;
+       strongarm-* | thumb-*)
+               basic_machine=arm-`echo $basic_machine | sed 's/^[^-]*-//'`
+               ;;
        sun2)
                basic_machine=m68000-sun
                ;;
@@ -953,17 +1136,9 @@ case $basic_machine in
                basic_machine=t90-cray
                os=-unicos
                ;;
-       tic54x | c54x*)
-               basic_machine=tic54x-unknown
-               os=-coff
-               ;;
-       tic55x | c55x*)
-               basic_machine=tic55x-unknown
-               os=-coff
-               ;;
-       tic6x | c6x*)
-               basic_machine=tic6x-unknown
-               os=-coff
+       tile*)
+               basic_machine=$basic_machine-unknown
+               os=-linux-gnu
                ;;
        tx39)
                basic_machine=mipstx39-unknown
@@ -1025,9 +1200,16 @@ case $basic_machine in
                basic_machine=hppa1.1-winbond
                os=-proelf
                ;;
+       xbox)
+               basic_machine=i686-pc
+               os=-mingw32
+               ;;
        xps | xps100)
                basic_machine=xps100-honeywell
                ;;
+       xscale-* | xscalee[bl]-*)
+               basic_machine=`echo $basic_machine | sed 's/^xscale/arm/'`
+               ;;
        ymp)
                basic_machine=ymp-cray
                os=-unicos
@@ -1036,6 +1218,10 @@ case $basic_machine in
                basic_machine=z8k-unknown
                os=-sim
                ;;
+       z80-*-coff)
+               basic_machine=z80-unknown
+               os=-sim
+               ;;
        none)
                basic_machine=none-none
                os=-none
@@ -1055,6 +1241,9 @@ case $basic_machine in
        romp)
                basic_machine=romp-ibm
                ;;
+       mmix)
+               basic_machine=mmix-knuth
+               ;;
        rs6000)
                basic_machine=rs6000-ibm
                ;;
@@ -1071,13 +1260,10 @@ case $basic_machine in
        we32k)
                basic_machine=we32k-att
                ;;
-       sh3 | sh4 | sh[34]eb | sh[1234]le | sh[23]ele)
+       sh[1234] | sh[24]a | sh[24]aeb | sh[34]eb | sh[1234]le | sh[23]ele)
                basic_machine=sh-unknown
                ;;
-       sh64)
-               basic_machine=sh64-unknown
-               ;;
-       sparc | sparcv9 | sparcv9b)
+       sparc | sparcv8 | sparcv9 | sparcv9b | sparcv9v)
                basic_machine=sparc-sun
                ;;
        cydra)
@@ -1121,9 +1307,12 @@ esac
 if [ x"$os" != x"" ]
 then
 case $os in
-        # First match some system type aliases
-        # that might get confused with valid system types.
+       # First match some system type aliases
+       # that might get confused with valid system types.
        # -solaris* is a basic system type, with this one exception.
+       -auroraux)
+               os=-auroraux
+               ;;
        -solaris1 | -solaris1.*)
                os=`echo $os | sed -e 's|solaris1|sunos4|'`
                ;;
@@ -1144,26 +1333,31 @@ case $os in
        # Each alternative MUST END IN A *, to match a version number.
        # -sysv* is not here because it comes later, after sysvr4.
        -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
-             | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\
-             | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
+             | -*vms* | -sco* | -esix* | -isc* | -aix* | -cnk* | -sunos | -sunos[34]*\
+             | -hpux* | -unos* | -osf* | -luna* | -dgux* | -auroraux* | -solaris* \
+             | -sym* | -kopensolaris* \
              | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
-             | -aos* \
+             | -aos* | -aros* \
              | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
              | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
-             | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* | -openbsd* \
+             | -hiux* | -386bsd* | -knetbsd* | -mirbsd* | -netbsd* \
+             | -openbsd* | -solidbsd* \
              | -ekkobsd* | -kfreebsd* | -freebsd* | -riscix* | -lynxos* \
              | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \
              | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
              | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
-             | -chorusos* | -chorusrdb* \
-             | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
-             | -mingw32* | -linux-gnu* | -linux-uclibc* | -uxpv* | -beos* | -mpeix* | -udk* \
+             | -chorusos* | -chorusrdb* | -cegcc* \
+             | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
+             | -mingw32* | -linux-gnu* | -linux-android* \
+             | -linux-newlib* | -linux-uclibc* \
+             | -uxpv* | -beos* | -mpeix* | -udk* \
              | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \
              | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \
              | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \
              | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \
              | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \
-             | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly*)
+             | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \
+             | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*)
        # Remember, each alternative MUST END IN *, to match a version number.
                ;;
        -qnx*)
@@ -1181,7 +1375,7 @@ case $os in
                os=`echo $os | sed -e 's|nto|nto-qnx|'`
                ;;
        -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \
-             | -windows* | -osx | -abug | -netware* | -os9* | -beos* \
+             | -windows* | -osx | -abug | -netware* | -os9* | -beos* | -haiku* \
              | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*)
                ;;
        -mac*)
@@ -1202,7 +1396,7 @@ case $os in
        -opened*)
                os=-openedition
                ;;
-        -os400*)
+       -os400*)
                os=-os400
                ;;
        -wince*)
@@ -1251,7 +1445,7 @@ case $os in
        -sinix*)
                os=-sysv4
                ;;
-        -tpf*)
+       -tpf*)
                os=-tpf
                ;;
        -triton*)
@@ -1290,6 +1484,14 @@ case $os in
        -kaos*)
                os=-kaos
                ;;
+       -zvmoe)
+               os=-zvmoe
+               ;;
+       -dicos*)
+               os=-dicos
+               ;;
+       -nacl*)
+               ;;
        -none)
                ;;
        *)
@@ -1312,6 +1514,12 @@ else
 # system, and we'll never get to this point.
 
 case $basic_machine in
+       score-*)
+               os=-elf
+               ;;
+       spu-*)
+               os=-elf
+               ;;
        *-acorn)
                os=-riscix1.2
                ;;
@@ -1321,9 +1529,18 @@ case $basic_machine in
        arm*-semi)
                os=-aout
                ;;
-    c4x-* | tic4x-*)
-        os=-coff
-        ;;
+       c4x-* | tic4x-*)
+               os=-coff
+               ;;
+       tic54x-*)
+               os=-coff
+               ;;
+       tic55x-*)
+               os=-coff
+               ;;
+       tic6x-*)
+               os=-coff
+               ;;
        # This must come before the *-dec entry.
        pdp10-*)
                os=-tops20
@@ -1349,6 +1566,9 @@ case $basic_machine in
        m68*-cisco)
                os=-aout
                ;;
+       mep-*)
+               os=-elf
+               ;;
        mips*-cisco)
                os=-elf
                ;;
@@ -1367,9 +1587,15 @@ case $basic_machine in
        *-be)
                os=-beos
                ;;
+       *-haiku)
+               os=-haiku
+               ;;
        *-ibm)
                os=-aix
                ;;
+       *-knuth)
+               os=-mmixware
+               ;;
        *-wec)
                os=-proelf
                ;;
@@ -1472,7 +1698,7 @@ case $basic_machine in
                        -sunos*)
                                vendor=sun
                                ;;
-                       -aix*)
+                       -cnk*|-aix*)
                                vendor=ibm
                                ;;
                        -beos*)
@@ -1535,7 +1761,7 @@ case $basic_machine in
 esac
 
 echo $basic_machine$os
-exit 0
+exit
 
 # Local variables:
 # eval: (add-hook 'write-file-hooks 'time-stamp)

diff --git a/config/m-nt.h b/config/m-nt.h
index 7a928281105c9827c28786472a93260c90ec0099..80e0b5ee6a6383a52187d445a58e34d7d7e0f329 100644 (file)
--- a/config/m-nt.h
+++ b/config/m-nt.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/m-templ.h b/config/m-templ.h
index 392ec562b8cfcdc89377d29741aca60428ac8873..6e09f64e4a23454a5fcdf321430462e528e89ac8 100644 (file)
--- a/config/m-templ.h
+++ b/config/m-templ.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/config/s-nt.h b/config/s-nt.h
index 5eaf3770f475e4dc2c11296d3f4c038ed0d3ec75..b21b7158a9d5b7bdbea3e956865b84a93abf335c 100644 (file)
--- a/config/s-nt.h
+++ b/config/s-nt.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -27,3 +27,4 @@
 #define HAS_MKTIME
 #define HAS_PUTENV
 #define HAS_LOCALE
+#define HAS_BROKEN_PRINTF

diff --git a/config/s-templ.h b/config/s-templ.h
index a65b178a8c3ab65d90b7fb309491add36613d543..971bc48f1e2eddfc5abea6375dd1147c5ef4386b 100644 (file)
--- a/config/s-templ.h
+++ b/config/s-templ.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -52,10 +52,10 @@
 /* Define SUPPORT_DYNAMIC_LINKING if dynamic loading of C stub code
    via dlopen() is available. */
 
-#define HAS_EXPM1_LOG1P
+#define HAS_C99_FLOAT_OPS
 
-/* Define HAS_EXPM1_LOG1P if the math functions expm1() and log1p()
-   are available.  (Standard C99 but not C89.) */
+/* Define HAS_C99_FLOAT_OPS if <math.h> conforms to ISO C99.
+   In particular, it should provide expm1(), log1p(), hypot(), copysign(). */
 
 /* 2. For the Unix library. */
 

diff --git a/configure b/configure
index 47cc2035125e3bdf749213b1146fa5f207c09c4a..4ed6ce1b209a174337f238e739ec2c42e0dd7239 100755 (executable)
--- a/configure
+++ b/configure
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -31,6 +31,7 @@ mathlib='-lm'
 dllib=''
 x11_include_dir=''
 x11_lib_dir=''
+graph_wanted=yes
 tk_wanted=yes
 pthread_wanted=yes
 tk_defs=''
@@ -39,9 +40,11 @@ tk_x11=yes
 dl_defs=''
 verbose=no
 withcurses=yes
+debugruntime=noruntimed
 withsharedlibs=yes
 gcc_warnings="-Wall"
 partialld="ld -r"
+withcamlp4=camlp4
 
 # Try to turn internationalization off, can cause config.guess to malfunction!
 unset LANG
@@ -81,14 +84,15 @@ while : ; do
         asppoption="$2"; shift;;
     -lib*)
         cclibs="$2 $cclibs"; shift;;
-    -no-curses)
+    -no-curses|--no-curses)
         withcurses=no;;
-    -no-shared-libs)
+    -no-shared-libs|--no-shared-libs)
         withsharedlibs=no;;
     -x11include*|--x11include*)
         x11_include_dir=$2; shift;;
     -x11lib*|--x11lib*)
         x11_lib_dir=$2; shift;;
+    -no-graph|--no-graph) graph_wanted=no;;
     -with-pthread*|--with-pthread*)
         ;; # Ignored for backward compatibility
     -no-pthread*|--no-pthread*)
@@ -109,6 +113,10 @@ while : ; do
         dllib="$2"; shift;;
     -verbose|--verbose)
         verbose=yes;;
+    -with-debug-runtime|--with-debug-runtime)
+        debugruntime=runtimed;;
+    -no-camlp4|--no-camlp4)
+        withcamlp4="";;
     *) echo "Unknown option \"$1\"." 1>&2; exit 2;;
   esac
   shift
@@ -123,17 +131,23 @@ esac
 case "$bindir" in
   /*) ;;
   "") ;;
-   *) echo "The -bindir directory must be absolute." 1>&2; exit 2;;
+  '$(PREFIX)/'*) ;;
+   *) echo 'The -bindir directory must be absolute or relative to $(PREFIX).'>&2
+      exit 2;;
 esac
 case "$libdir" in
   /*) ;;
   "") ;;
-   *) echo "The -libdir directory must be absolute." 1>&2; exit 2;;
+  '$(PREFIX)/'*) ;;
+   *) echo 'The -libdir directory must be absolute or relative to $(PREFIX).'>&2
+      exit 2;;
 esac
 case "$mandir" in
   /*) ;;
   "") ;;
-   *) echo "The -mandir directory must be absolute." 1>&2; exit 2;;
+  '$(PREFIX)/'*) ;;
+   *) echo 'The -mandir directory must be absolute or relative to $(PREFIX).'>&2
+      exit 2;;
 esac
 
 # Generate the files
@@ -206,14 +220,14 @@ case "$host,$cc" in
 
 WARNING: you are using gcc version 2.7.2.1 on an Intel x86 processor.
 This version of gcc is known to generate incorrect code for the
-Objective Caml runtime system on some Intel x86 machines. (The symptom
+OCaml runtime system on some Intel x86 machines. (The symptom
 is a crash of boot/ocamlc when compiling stdlib/pervasives.mli.)
 In particular, the version of gcc 2.7.2.1 that comes with
 Linux RedHat 4.x / Intel is affected by this problem.
 Other Linux distributions might also be affected.
 If you are using one of these configurations, you are strongly advised
 to use another version of gcc, such as 2.95, which are
-known to work well with Objective Caml.
+known to work well with OCaml.
 
 Press <enter> to proceed or <interrupt> to stop.
 EOF
@@ -222,7 +236,7 @@ EOF
 
 WARNING: you are using gcc version 2.96 on an Intel x86 processor.
 Certain patched versions of gcc 2.96 are known to generate incorrect
-code for the Objective Caml runtime system.  (The symptom is a segmentation
+code for the OCaml runtime system.  (The symptom is a segmentation
 violation on boot/ocamlc.)  Those incorrectly patched versions can be found
 in RedHat 7.2 and Mandrake 8.0 and 8.1; other Linux distributions
 might also be affected.  (See bug #57760 on bugzilla.redhat.com)
@@ -259,7 +273,7 @@ case "$bytecc,$host" in
     bytecccompopts="-fno-defer-pop $gcc_warnings -DSHRINKED_GNUC"
     mathlib="";;
   *,*-*-darwin*)
-    bytecccompopts="-fno-defer-pop -no-cpp-precomp $gcc_warnings"
+    bytecccompopts="-fno-defer-pop $gcc_warnings"
     mathlib=""
     # Tell gcc that we can use 32-bit code addresses for threaded code
     # unless we are compiled for a shared library (-fPIC option)
@@ -306,7 +320,7 @@ case "$bytecc,$host" in
     bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32"
     dllccompopts="-U_WIN32 -DCAML_DLL"
     if test $withsharedlibs = yes; then
-      flexlink="flexlink -chain cygwin -merge-manifest"
+      flexlink="flexlink -chain cygwin -merge-manifest -stack 16777216"
       flexdir=`$flexlink -where | dos2unix`
       if test -z "$flexdir"; then
         echo "flexlink not found: native shared libraries won't be available"
@@ -340,7 +354,7 @@ sh ./runtest ansi.c
 case $? in
   0) echo "The C compiler is ANSI-compliant.";;
   1) echo "The C compiler $cc is not ANSI-compliant."
-     echo "You need an ANSI C compiler to build Objective Caml."
+     echo "You need an ANSI C compiler to build OCaml."
      exit 2;;
   *) echo "Unable to compile the test program."
      echo "Make sure the C compiler $cc is properly installed."
@@ -359,7 +373,7 @@ case "$2,$3" in
        echo "#define ARCH_SIXTYFOUR" >> m.h
        arch64=true;;
   *,*) echo "This architecture seems to be neither 32 bits nor 64 bits."
-       echo "Objective Caml won't run on this architecture."
+       echo "OCaml won't run on this architecture."
        exit 2;;
     *) echo "Unable to compile the test program."
        echo "Make sure the C compiler $cc is properly installed."
@@ -368,7 +382,7 @@ esac
 if test $1 != 4 && test $2 != 4 && test $4 != 4; then
   echo "Sorry, we can't find a 32-bit integer type"
   echo "(sizeof(short) = $4, sizeof(int) = $1, sizeof(long) = $2)"
-  echo "Objective Caml won't run on this architecture."
+  echo "OCaml won't run on this architecture."
   exit 2
 fi
 
@@ -410,7 +424,7 @@ fi
 
 if test $3 = 8 && test $int64_native = false; then
   echo "This architecture has 64-bit pointers but no 64-bit integer type."
-  echo "Objective Caml won't run on this architecture."
+  echo "OCaml won't run on this architecture."
   exit 2
 fi
 
@@ -423,7 +437,7 @@ case $? in
   1) echo "This is a little-endian architecture."
      echo "#undef ARCH_BIG_ENDIAN" >> m.h;;
   2) echo "This architecture seems to be neither big endian nor little endian."
-     echo "Objective Caml won't run on this architecture."
+     echo "OCaml won't run on this architecture."
      exit 2;;
   *) echo "Something went wrong during endianness determination."
      echo "You'll have to figure out endianness yourself"
@@ -458,7 +472,7 @@ case "$host" in
          echo "#define ARCH_ALIGN_DOUBLE" >> m.h;;
       *) echo "Something went wrong during alignment determination for doubles."
          echo "I'm going to assume this architecture has alignment constraints over doubles."
-         echo "That's a safe bet: Objective Caml will work even if"
+         echo "That's a safe bet: OCaml will work even if"
          echo "this architecture has actually no alignment constraints."
          echo "#define ARCH_ALIGN_DOUBLE" >> m.h;;
     esac;;
@@ -484,7 +498,7 @@ if $int64_native; then
            echo "#define ARCH_ALIGN_INT64" >> m.h;;
         *) echo "Something went wrong during alignment determination for 64-bit integers."
            echo "I'm going to assume this architecture has alignment constraints."
-           echo "That's a safe bet: Objective Caml will work even if"
+           echo "That's a safe bet: OCaml will work even if"
            echo "this architecture has actually no alignment constraints."
            echo "#define ARCH_ALIGN_INT64" >> m.h;;
       esac
@@ -576,13 +590,7 @@ if test $withsharedlibs = "yes"; then
       byteccrpath="-Wl,-rpath,"
       mksharedlibrpath="-rpath "
       shared_libraries_supported=true;;
-    i[3456]86-*-darwin10.*)
-       mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress"
-       bytecccompopts="$dl_defs $bytecccompopts"
-       dl_needs_underscore=false
-       shared_libraries_supported=true
-       ;;
-    i[3456]86-*-darwin*)
+    i[3456]86-*-darwin[89].*)
       mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -read_only_relocs suppress"
       bytecccompopts="$dl_defs $bytecccompopts"
       dl_needs_underscore=false
@@ -620,11 +628,12 @@ if test $withsharedlibs = "yes"; then
     *-*-cygwin*)                  natdynlink=true;;
     i[3456]86-*-linux*)           natdynlink=true;;
     x86_64-*-linux*)              natdynlink=true;;
-    i[3456]86-*-darwin10.*)
+    i[3456]86-*-darwin[89].*)     natdynlink=true;;
+    i[3456]86-*-darwin*)
       if test $arch64 == true; then
         natdynlink=true
       fi;;
-    i[3456]86-*-darwin[89]*)      natdynlink=true;;
+    x86_64-*-darwin*)             natdynlink=true;;
     powerpc64-*-linux*)           natdynlink=true;;
     sparc-*-linux*)               natdynlink=true;;
     i686-*-kfreebsd*)             natdynlink=true;;
@@ -636,6 +645,7 @@ if test $withsharedlibs = "yes"; then
     i[345]86-*-netbsd*)           natdynlink=true;;
     x86_64-*-netbsd*)             natdynlink=true;;
     i386-*-gnu0.3)                natdynlink=true;;
+    arm*-*-linux*)                natdynlink=true;;
   esac
 fi
 
@@ -653,13 +663,6 @@ model=default
 system=unknown
 
 case "$host" in
-  alpha*-*-osf*)                arch=alpha; system=digital;;
-  alpha*-*-linux*)              arch=alpha; system=linux;;
-  alpha*-*-gnu*)                arch=alpha; system=gnu;;
-  alpha*-*-freebsd*)            arch=alpha; system=freebsd;;
-  alpha*-*-netbsd*)             arch=alpha; system=netbsd;;
-  alpha*-*-openbsd*)            arch=alpha; system=openbsd;;
-  sparc*-*-sunos4.*)            arch=sparc; system=sunos;;
   sparc*-*-solaris2.*)          arch=sparc; system=solaris;;
   sparc*-*-*bsd*)               arch=sparc; system=bsd;;
   sparc*-*-linux*)              arch=sparc; system=linux;;
@@ -680,27 +683,24 @@ case "$host" in
                                   arch=i386; system=macosx
                                 fi;;
   i[3456]86-*-gnu*)             arch=i386; system=gnu;;
-  mips-*-irix6*)                arch=mips; system=irix;;
-  hppa1.1-*-hpux*)              arch=hppa; system=hpux;;
-  hppa2.0*-*-hpux*)             arch=hppa; system=hpux;;
-  hppa*-*-linux*)               arch=hppa; system=linux;;
-  hppa*-*-gnu*)                 arch=hppa; system=gnu;;
   powerpc*-*-linux*)            arch=power; model=ppc; system=elf;;
   powerpc-*-netbsd*)            arch=power; model=ppc; system=elf;;
   powerpc-*-rhapsody*)          arch=power; model=ppc; system=rhapsody;;
   powerpc-*-darwin*)            arch=power; system=rhapsody
                                 if $arch64; then model=ppc64; else model=ppc; fi;;
-  arm*-*-linux*)                arch=arm; system=linux;;
-  arm*-*-gnu*)                  arch=arm; system=gnu;;
-  ia64-*-linux*)                arch=ia64; system=linux;;
-  ia64-*-gnu*)                  arch=ia64; system=gnu;;
-  ia64-*-freebsd*)              arch=ia64; system=freebsd;;
+  arm*-*-linux-gnueabihf)       arch=arm; system=linux_eabihf;;
+  armv7*-*-linux-gnueabi)       arch=arm; model=armv7; system=linux_eabi;;
+  armv6t2*-*-linux-gnueabi)     arch=arm; model=armv6t2; system=linux_eabi;;
+  armv6*-*-linux-gnueabi)       arch=arm; model=armv6; system=linux_eabi;;
+  armv5te*-*-linux-gnueabi)     arch=arm; model=armv5te; system=linux_eabi;;
+  armv5*-*-linux-gnueabi)       arch=arm; model=armv5; system=linux_eabi;;
+  arm*-*-linux-gnueabi)         arch=arm; system=linux_eabi;;
   x86_64-*-linux*)              arch=amd64; system=linux;;
   x86_64-*-gnu*)                arch=amd64; system=gnu;;
   x86_64-*-freebsd*)            arch=amd64; system=freebsd;;
   x86_64-*-netbsd*)             arch=amd64; system=netbsd;;
   x86_64-*-openbsd*)            arch=amd64; system=openbsd;;
-  x86_64-*-darwin9.5)           arch=amd64; system=macosx;;
+  x86_64-*-darwin*)             arch=amd64; system=macosx;;
 esac
 
 # Some platforms exist both in 32-bit and 64-bit variants, not distinguished
@@ -709,17 +709,13 @@ esac
 
 if $arch64; then
   case "$arch,$model" in
-    sparc,default|mips,default|hppa,default|power,ppc)
+    sparc,default|power,ppc)
       arch=none; model=default; system=unknown;;
   esac
 fi
 
 if test -z "$ccoption"; then
-  case "$arch,$system,$cc" in
-    alpha,digital,gcc*) nativecc=cc;;
-    mips,*,gcc*) nativecc=cc;;
-    *) nativecc="$bytecc";;
-  esac
+  nativecc="$bytecc"
 else
   nativecc="$ccoption"
 fi
@@ -729,9 +725,6 @@ nativecclinkopts=''
 nativeccrpath="$byteccrpath"
 
 case "$arch,$nativecc,$system,$host_type" in
-  alpha,cc*,digital,*) nativecccompopts=-std1;;
-  mips,cc*,irix,*)     nativecccompopts=-n32
-                       nativecclinkopts="-n32 -Wl,-woff,84";;
   *,*,nextstep,*)      nativecccompopts="$gcc_warnings -U__GNUC__ -posix"
                        nativecclinkopts="-posix";;
   *,*,rhapsody,*darwin[1-5].*)
@@ -747,11 +740,6 @@ esac
 asppprofflags='-DPROFILING'
 
 case "$arch,$model,$system" in
-  alpha,*,digital)  as='as -O2 -nocpp'
-                    aspp='as -O2'
-                    asppprofflags='-pg -DPROFILING';;
-  alpha,*,*)        as='as'
-                    aspp='gcc -c';;
   amd64,*,macosx)   as='as -arch x86_64'
                     aspp='gcc -arch x86_64 -c';;
   amd64,*,solaris)  as='as --64'
@@ -760,16 +748,10 @@ case "$arch,$model,$system" in
                     aspp='gcc -c';;
   arm,*,*)          as='as';
                     aspp='gcc -c';;
-  hppa,*,*)         as='as';
-                    aspp='gcc -traditional -c';;
   i386,*,solaris)   as='as'
                     aspp='/usr/ccs/bin/as -P';;
   i386,*,*)         as='as'
                     aspp='gcc -c';;
-  ia64,*,*)         as='as -xexplicit'
-                    aspp='gcc -c -Wa,-xexplicit';;
-  mips,*,irix)      as='as -n32 -O2 -nocpp -g0'
-                    aspp='as -n32 -O2';;
   power,*,elf)      as='as -u -m ppc'
                     aspp='gcc -c';;
   power,*,bsd)      as='as'
@@ -790,7 +772,6 @@ if test -n "$asppoption"; then aspp="$asppoption"; fi
 
 cc_profile='-pg'
 case "$arch,$model,$system" in
-  alpha,*,digital) profiling='prof';;
   i386,*,linux_elf) profiling='prof';;
   i386,*,gnu) profiling='prof';;
   i386,*,bsd_elf) profiling='prof';;
@@ -801,6 +782,7 @@ case "$arch,$model,$system" in
     case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;;
   amd64,*,linux) profiling='prof';;
   amd64,*,gnu) profiling='prof';;
+  arm,*,linux*) profiling='prof';;
   *) profiling='noprof';;
 esac
 
@@ -816,6 +798,9 @@ else
   echo "RANLIBCMD=" >> Makefile
 fi
 
+echo "ARCMD=ar" >> Makefile
+
+
 # Do #! scripts work?
 
 if (SHELL=/bin/sh; export SHELL; (./sharpbang || ./sharpbang2) >/dev/null); then
@@ -867,9 +852,9 @@ fi
 
 # For the Pervasives module
 
-if sh ./trycompile expm1.c $mathlib; then
-  echo "expm1() and log1p() found."
-  echo "#define HAS_EXPM1_LOG1P" >> s.h
+if sh ./hasgot2 -i math.h $mathlib expm1 log1p hypot copysign; then
+  echo "expm1(), log1p(), hypot(), copysign() found."
+  echo "#define HAS_C99_FLOAT_OPS" >> s.h
 fi
 
 # For the Sys module
@@ -1056,14 +1041,7 @@ if sh ./hasgot -i termios.h &&
   echo "#define HAS_TERMIOS" >> s.h
 fi
 
-# Async I/O under OSF1 3.x are so buggy that the test program hangs...
-testasyncio=true
-if test -f /usr/bin/uname; then
-  case "`/usr/bin/uname -s -r`" in
-    "OSF1 V3."*) testasyncio=false;;
-  esac
-fi
-if $testasyncio && sh ./runtest async_io.c; then
+if sh ./runtest async_io.c; then
   echo "Asynchronous I/O are supported."
   echo "#define HAS_ASYNC_IO" >> s.h
 fi
@@ -1138,6 +1116,11 @@ if sh ./hasgot -i sys/types.h -i sys/mman.h && sh ./hasgot mmap munmap; then
   echo "#define HAS_MMAP" >> s.h
 fi
 
+if sh ./hasgot pwrite; then
+  echo "pwrite() found"
+  echo "#define HAS_PWRITE" >> s.h
+fi
+
 nargs=none
 for i in 5 6; do
   if sh ./trycompile -DNUM_ARGS=${i} gethostbyname.c; then nargs=$i; break; fi
@@ -1170,7 +1153,7 @@ fi
 # Determine if system stack overflows can be detected
 
 case "$arch,$system" in
-  i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx|amd64,macosx)
+  i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx)
     echo "System stack overflow can be detected."
     echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;;
   *)
@@ -1180,13 +1163,11 @@ esac
 # Determine the target architecture for the "num" library
 
 case "$arch" in
-  alpha)    bng_arch=alpha; bng_asm_level=1;;
   i386)     bng_arch=ia32
             if sh ./trycompile ia32sse2.c
             then bng_asm_level=2
             else bng_asm_level=1
             fi;;
-  mips)     bng_arch=mips; bng_asm_level=1;;
   power)    bng_arch=ppc; bng_asm_level=1;;
   amd64)    bng_arch=amd64; bng_asm_level=1;;
   *)        bng_arch=generic; bng_asm_level=0;;
@@ -1253,10 +1234,22 @@ fi
 
 # Determine the location of X include files and libraries
 
+# If the user specified -x11include and/or -x11lib, these settings
+# are used. Otherwise, we check whether there is pkg-config, and take
+# the flags from there. Otherwise, we search the location.
+
 x11_include="not found"
 x11_link="not found"
 
-for dir in \
+if test -z "$x11_include_dir" -a -z "$x11_lib_dir"; then
+  if pkg-config --exists x11 2>/dev/null; then
+    x11_include=`pkg-config --cflags x11`
+    x11_link=`pkg-config --libs x11`
+  fi
+fi
+
+if test "$x11_include" = "not found"; then
+  for dir in \
     $x11_include_dir          \
                               \
     /usr/X11R7/include        \
@@ -1302,20 +1295,21 @@ for dir in \
     /usr/openwin/include      \
     /usr/openwin/share/include \
     ; \
-do
-  if test -f $dir/X11/X.h; then
-    x11_include=$dir
-    break
-  fi
-done
+    do
+    if test -f $dir/X11/X.h; then
+      x11_include_dir=$dir
+      x11_include="-I$dir"
+      break
+    fi
+  done
 
-if test "$x11_include" = "not found"; then
-  x11_try_lib_dir=''
-else
-  x11_try_lib_dir=`echo $x11_include | sed -e 's|include|lib|'`
-fi
+  if test "$x11_include" = "not found"; then
+      x11_try_lib_dir=''
+  else
+      x11_try_lib_dir=`echo $x11_include_dir | sed -e 's|include|lib|'`
+  fi
 
-for dir in \
+  for dir in \
     $x11_lib_dir          \
     $x11_try_lib_dir      \
                           \
@@ -1357,93 +1351,62 @@ for dir in \
     /lib/usr/lib/X11      \
                           \
     /usr/openwin/lib      \
-    /usr/openwin/share/lib \
+    /usr/openwin/share/lib    \
+                              \
+    /usr/lib/i386-linux-gnu   \
+    /usr/lib/x86_64-linux-gnu \
     ; \
-do
-  if test -f $dir/libX11.a || \
-     test -f $dir/libX11.so || \
-     test -f $dir/libX11.dll.a || \
-     test -f $dir/libX11.dylib || \
-     test -f $dir/libX11.sa; then
-    if test $dir = /usr/lib; then
-      x11_link="-lX11"
-    else
-      x11_libs="-L$dir"
-      case "$host" in
-        *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";;
-        *) x11_link="-L$dir -lX11";;
-      esac
+    do
+    if test -f $dir/libX11.a || \
+       test -f $dir/libX11.so || \
+       test -f $dir/libX11.dll.a || \
+       test -f $dir/libX11.dylib || \
+       test -f $dir/libX11.sa; then
+      if test $dir = /usr/lib; then
+        x11_link="-lX11"
+      else
+        x11_libs="-L$dir"
+        case "$host" in
+          *-kfreebsd*-gnu) x11_link="-L$dir -lX11";;
+          *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";;
+          *) x11_link="-L$dir -lX11";;
+        esac
+      fi
+      break
     fi
-    break
-  fi
-done
+  done
+fi
 
+if test "x11_include" != "not found"; then
+  if test "$x11_include" = "-I/usr/include"; then
+    x11_include=""
+  fi
+  if ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then
+    echo "X11 works"
+  else
+    echo "Cannot compile X11 program"
+    x11_include="not found"
+  fi
+fi
 
+has_graph=false
 if test "$x11_include" = "not found" || test "$x11_link" = "not found"
 then
   echo "X11 not found, the \"graph\" library will not be supported."
-  x11_include=""
+  x11_include="not found"
+  x11_link="not found"
 else
-  echo "Location of X11 include files: $x11_include/X11"
+  echo "Options for compiling for X11: $x11_include"
   echo "Options for linking with X11: $x11_link"
-  otherlibraries="$otherlibraries graph"
-  if test "$x11_include" = "/usr/include"; then
-    x11_include=""
-  else
-    x11_include="-I$x11_include"
+  if test "$graph_wanted" = yes
+  then
+    has_graph=true
+    otherlibraries="$otherlibraries graph"
   fi
 fi
 echo "X11_INCLUDES=$x11_include" >> Makefile
 echo "X11_LINK=$x11_link" >> Makefile
 
-# See if we can compile the dbm library
-
-dbm_include="not found"
-dbm_link="not found"
-use_gdbm_ndbm=no
-
-for dir in /usr/include /usr/include/db1 /usr/include/gdbm; do
-  if test -f $dir/ndbm.h; then
-    dbm_include=$dir
-    if sh ./hasgot dbm_open; then
-      dbm_link=""
-    elif sh ./hasgot -lndbm dbm_open; then
-      dbm_link="-lndbm"
-    elif sh ./hasgot -ldb1 dbm_open; then
-      dbm_link="-ldb1"
-    elif sh ./hasgot -lgdbm dbm_open; then
-      dbm_link="-lgdbm"
-    elif sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then
-      dbm_link="-lgdbm_compat -lgdbm"
-    fi
-    break
-  fi
-  if test -f $dir/gdbm-ndbm.h; then
-    dbm_include=$dir
-    use_gdbm_ndbm=yes
-    if sh ./hasgot -lgdbm_compat -lgdbm dbm_open; then
-      dbm_link="-lgdbm_compat -lgdbm"
-    fi
-    break
-  fi
-done
-if test "$dbm_include" = "not found" || test "$dbm_link" = "not found"; then
-  echo "NDBM not found, the \"dbm\" library will not be supported."
-else
-  echo "NDBM found (in $dbm_include)"
-  if test "$dbm_include" = "/usr/include"; then
-    dbm_include=""
-  else
-    dbm_include="-I$dbm_include"
-  fi
-  if test "$use_gdbm_ndbm" = "yes"; then
-    echo "#define DBM_USES_GDBM_NDBM" >> s.h
-  fi
-  otherlibraries="$otherlibraries dbm"
-fi
-echo "DBM_INCLUDES=$dbm_include" >> Makefile
-echo "DBM_LINK=$dbm_link" >> Makefile
-
 # Look for tcl/tk
 
 echo "Configuring LablTk..."
@@ -1453,11 +1416,11 @@ if test $tk_wanted = no; then
 elif test $tk_x11 = no; then
   has_tk=true
 elif test "$x11_include" = "not found" || test "$x11_link" = "not found"; then
-  echo "X11 not found."
+  echo "X11 not found or disabled."
   has_tk=false
 else
   tk_x11_include="$x11_include"
-  tk_x11_libs="$x11_libs -lX11"
+  tk_x11_libs="$x11_link"
   has_tk=true
 fi
 
@@ -1484,14 +1447,14 @@ if test $has_tk = true; then
   if test -n "$tcl_version" && test "x$tcl_version" != "xnone"; then
     echo "tcl.h and tk.h version $tcl_version found with \"$tk_defs\"."
     case $tcl_version in
-    7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;;
-    7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;;
-    8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;;
-    8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;;
-    8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;;
-    8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;;
-    8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;;
     8.5) tclmaj=8 tclmin=5 tkmaj=8 tkmin=5 ;;
+    8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;;
+    8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;;
+    8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;;
+    8.1) tclmaj=8 tclmin=1 tkmaj=8 tkmin=1 ;;
+    8.0) tclmaj=8 tclmin=0 tkmaj=8 tkmin=0 ;;
+    7.6) tclmaj=7 tclmin=6 tkmaj=4 tkmin=2 ;;
+    7.5) tclmaj=7 tclmin=5 tkmaj=4 tkmin=1 ;;
     *) echo "This version is not known."; has_tk=false ;;
     esac
   else
@@ -1537,10 +1500,6 @@ if test $has_tk = true; then
   fi
 fi
 
-case "$host" in
-  *-*-cygwin*) tk_libs="$tk_libs -lws2_32";;
-esac
-
 if test $has_tk = true; then
   if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then
     echo "Tcl/Tk libraries found."
@@ -1591,6 +1550,17 @@ else
   echo "LIBBFD_LINK=" >> Makefile
 fi
 
+# Check whether assembler supports CFI directives
+
+asm_cfi_supported=false
+
+export aspp
+
+if sh ./tryassemble cfi.S; then
+  echo "#define ASM_CFI_SUPPORTED" >> m.h
+  asm_cfi_supported=true
+fi
+
 # Final twiddling of compiler options to work around known bugs
 
 nativeccprofopts="$nativecccompopts"
@@ -1660,6 +1630,9 @@ echo "CMXS=$cmxs" >> Makefile
 echo "MKEXE=$mkexe" >> Makefile
 echo "MKDLL=$mksharedlib" >> Makefile
 echo "MKMAINDLL=$mkmaindll" >> Makefile
+echo "RUNTIMED=${debugruntime}" >>Makefile
+echo "CAMLP4=${withcamlp4}" >>Makefile
+echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile
 
 rm -f tst hasgot.c
 rm -f ../m.h ../s.h ../Makefile
@@ -1670,7 +1643,7 @@ mv m.h s.h Makefile ..
 echo
 echo "** Configuration summary **"
 echo
-echo "Directories where Objective Caml will be installed:"
+echo "Directories where OCaml will be installed:"
 echo "        binaries.................. $bindir"
 echo "        standard library.......... $libdir"
 echo "        manual pages.............. $mandir (with extension .$manext)"
@@ -1704,6 +1677,11 @@ else
   echo "        options for linking....... $nativecclinkopts $cclibs"
   echo "        assembler ................ $as"
   echo "        preprocessed assembler ... $aspp"
+  if test "$asm_cfi_supported" = "true"; then
+  echo "        assembler supports CFI ... yes"
+  else
+  echo "        assembler supports CFI ... no"
+  fi
   echo "        native dynlink ........... $natdynlink"
   if test "$profiling" = "prof"; then
   echo "        profiling with gprof ..... supported"
@@ -1718,27 +1696,38 @@ else
   echo "Source-level replay debugger: not supported"
 fi
 
+if test "$debugruntime" = "runtimed"; then
+  echo "Debug runtime will be compiled and installed"
+fi
+
 echo "Additional libraries supported:"
 echo "        $otherlibraries"
 
 echo "Configuration for the \"num\" library:"
 echo "        target architecture ...... $bng_arch (asm level $bng_asm_level)"
 
-if test "$x11_include" != "not found" && test "$x11_lib" != "not found"; then
+if $has_graph; then
 echo "Configuration for the \"graph\" library:"
 echo "        options for compiling .... $x11_include"
 echo "        options for linking ...... $x11_link"
+else
+echo "The \"graph\" library: not supported"
 fi
 
 if test $has_tk = true; then
 echo "Configuration for the \"labltk\" library:"
 echo "        use tcl/tk version ....... $tcl_version"
-echo "        options for compiling .... $tk_defs"
-echo "        options for linking ...... $tk_libs"
+echo "        options for compiling .... $tk_defs $x11_includes"
+echo "        options for linking ...... $tk_libs $x11_link"
 else
 echo "The \"labltk\" library: not supported"
 fi
 
 echo
-echo "** Objective Caml configuration completed successfully **"
+echo "** OCaml configuration completed successfully **"
 echo
+
+if test ! -z "$MACOSX_DEPLOYMENT_TARGET"; then
+  echo "WARNING: the environment variable MACOSX_DEPLOYMENT_TARGET is set."
+  echo "This will probably prevent compiling the OCaml system."
+fi

diff --git a/debugger/.cvsignore b/debugger/.cvsignore
deleted file mode 100644 (file)
index 45440f8..0000000
--- a/debugger/.cvsignore
+++ /dev/null
@@ -1,6 +0,0 @@
-lexer.ml
-parser.ml
-parser.mli
-ocamldebug
-dynlink.ml
-dynlink.mli

diff --git a/debugger/.depend b/debugger/.depend
index 1a04b1eaaa7987a8d2a6b555ad953e7e19f5d0fd..e3c107ab3fc5fd0f054efbef3e3049a16f917745 100644 (file)
--- a/debugger/.depend
+++ b/debugger/.depend
@@ -1,46 +1,48 @@
-breakpoints.cmi: primitives.cmi ../bytecomp/instruct.cmi
-checkpoints.cmi: primitives.cmi debugcom.cmi
-command_line.cmi:
-debugcom.cmi: primitives.cmi
-debugger_config.cmi:
-dynlink.cmi:
-envaux.cmi: ../typing/path.cmi ../bytecomp/instruct.cmi ../typing/env.cmi
-eval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
+breakpoints.cmi : primitives.cmi ../bytecomp/instruct.cmi
+checkpoints.cmi : primitives.cmi debugcom.cmi
+command_line.cmi :
+debugcom.cmi : primitives.cmi
+debugger_config.cmi :
+dynlink.cmi :
+envaux.cmi : ../typing/path.cmi ../bytecomp/instruct.cmi ../typing/env.cmi
+eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
     ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \
     ../typing/env.cmi debugcom.cmi
-events.cmi: ../bytecomp/instruct.cmi
-exec.cmi:
-frames.cmi: primitives.cmi ../bytecomp/instruct.cmi
-history.cmi:
-input_handling.cmi: primitives.cmi
-int64ops.cmi:
-lexer.cmi: parser.cmi
-loadprinter.cmi: ../parsing/longident.cmi dynlink.cmi
-parameters.cmi:
-parser.cmi: parser_aux.cmi ../parsing/longident.cmi
-parser_aux.cmi: primitives.cmi ../parsing/longident.cmi
-pattern_matching.cmi: ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi
-pos.cmi: ../bytecomp/instruct.cmi
-primitives.cmi: $(UNIXDIR)/unix.cmi
-printval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
+events.cmi : ../bytecomp/instruct.cmi
+exec.cmi :
+frames.cmi : primitives.cmi ../bytecomp/instruct.cmi
+history.cmi :
+input_handling.cmi : primitives.cmi
+int64ops.cmi :
+lexer.cmi : parser.cmi
+loadprinter.cmi : ../parsing/longident.cmi dynlink.cmi
+parameters.cmi :
+parser.cmi : parser_aux.cmi ../parsing/longident.cmi
+parser_aux.cmi : primitives.cmi ../parsing/longident.cmi
+pattern_matching.cmi : ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi
+pos.cmi : ../bytecomp/instruct.cmi
+primitives.cmi : $(UNIXDIR)/unix.cmi
+printval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \
     ../typing/env.cmi debugcom.cmi
-program_loading.cmi: primitives.cmi
-program_management.cmi:
-question.cmi:
-show_information.cmi: ../bytecomp/instruct.cmi
-show_source.cmi: ../bytecomp/instruct.cmi
-source.cmi:
-symbols.cmi: ../bytecomp/instruct.cmi
-time_travel.cmi: primitives.cmi
-trap_barrier.cmi:
-unix_tools.cmi: $(UNIXDIR)/unix.cmi
-breakpoints.cmo: symbols.cmi primitives.cmi pos.cmi ../bytecomp/instruct.cmi \
-    exec.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi
-breakpoints.cmx: symbols.cmx primitives.cmx pos.cmx ../bytecomp/instruct.cmx \
-    exec.cmx debugcom.cmx checkpoints.cmx breakpoints.cmi
-checkpoints.cmo: primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi
-checkpoints.cmx: primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi
-command_line.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \
+program_loading.cmi : primitives.cmi
+program_management.cmi :
+question.cmi :
+show_information.cmi : ../bytecomp/instruct.cmi
+show_source.cmi : ../bytecomp/instruct.cmi
+source.cmi :
+symbols.cmi : ../bytecomp/instruct.cmi
+time_travel.cmi : primitives.cmi
+trap_barrier.cmi :
+unix_tools.cmi : $(UNIXDIR)/unix.cmi
+breakpoints.cmo : symbols.cmi primitives.cmi pos.cmi \
+    ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \
+    breakpoints.cmi
+breakpoints.cmx : symbols.cmx primitives.cmx pos.cmx \
+    ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \
+    breakpoints.cmi
+checkpoints.cmo : primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi
+checkpoints.cmx : primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi
+command_line.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \
     ../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \
     show_source.cmi show_information.cmi question.cmi program_management.cmi \
     program_loading.cmi printval.cmi primitives.cmi pos.cmi parser_aux.cmi \
@@ -50,7 +52,7 @@ command_line.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \
     events.cmi eval.cmi envaux.cmi debugger_config.cmi debugcom.cmi \
     ../typing/ctype.cmi ../utils/config.cmi checkpoints.cmi breakpoints.cmi \
     command_line.cmi
-command_line.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \
+command_line.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \
     ../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \
     show_source.cmx show_information.cmx question.cmx program_management.cmx \
     program_loading.cmx printval.cmx primitives.cmx pos.cmx parser_aux.cmi \
@@ -60,153 +62,155 @@ command_line.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \
     events.cmx eval.cmx envaux.cmx debugger_config.cmx debugcom.cmx \
     ../typing/ctype.cmx ../utils/config.cmx checkpoints.cmx breakpoints.cmx \
     command_line.cmi
-debugcom.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \
+debugcom.cmo : primitives.cmi ../utils/misc.cmi int64ops.cmi \
     input_handling.cmi debugcom.cmi
-debugcom.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \
+debugcom.cmx : primitives.cmx ../utils/misc.cmx int64ops.cmx \
     input_handling.cmx debugcom.cmi
-debugger_config.cmo: int64ops.cmi debugger_config.cmi
-debugger_config.cmx: int64ops.cmx debugger_config.cmi
-dynlink.cmo: ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \
+debugger_config.cmo : int64ops.cmi debugger_config.cmi
+debugger_config.cmx : int64ops.cmx debugger_config.cmi
+dynlink.cmo : ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \
     ../utils/misc.cmi ../bytecomp/meta.cmi ../bytecomp/dll.cmi \
     ../utils/consistbl.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \
     dynlink.cmi
-dynlink.cmx: ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \
+dynlink.cmx : ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \
     ../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \
     ../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \
     dynlink.cmi
-envaux.cmo: ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \
+envaux.cmo : ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \
     ../typing/path.cmi ../typing/mtype.cmi ../utils/misc.cmi \
     ../bytecomp/instruct.cmi ../typing/env.cmi envaux.cmi
-envaux.cmx: ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \
+envaux.cmx : ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \
     ../typing/path.cmx ../typing/mtype.cmx ../utils/misc.cmx \
     ../bytecomp/instruct.cmx ../typing/env.cmx envaux.cmi
-eval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \
+eval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \
     printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \
     ../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \
     ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \
     frames.cmi ../typing/env.cmi debugcom.cmi ../typing/ctype.cmi \
     ../typing/btype.cmi eval.cmi
-eval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \
+eval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \
     printval.cmx ../typing/printtyp.cmx ../typing/predef.cmx \
     ../typing/path.cmx parser_aux.cmi ../utils/misc.cmx \
     ../parsing/longident.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \
     frames.cmx ../typing/env.cmx debugcom.cmx ../typing/ctype.cmx \
     ../typing/btype.cmx eval.cmi
-events.cmo: ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi
-events.cmx: ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi
-exec.cmo: exec.cmi
-exec.cmx: exec.cmi
-frames.cmo: symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi events.cmi \
-    debugcom.cmi frames.cmi
-frames.cmx: symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx events.cmx \
-    debugcom.cmx frames.cmi
-history.cmo: primitives.cmi int64ops.cmi debugger_config.cmi checkpoints.cmi \
-    history.cmi
-history.cmx: primitives.cmx int64ops.cmx debugger_config.cmx checkpoints.cmx \
-    history.cmi
-input_handling.cmo: $(UNIXDIR)/unix.cmi primitives.cmi \
+events.cmo : ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi
+events.cmx : ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi
+exec.cmo : exec.cmi
+exec.cmx : exec.cmi
+frames.cmo : symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi \
+    events.cmi debugcom.cmi frames.cmi
+frames.cmx : symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx \
+    events.cmx debugcom.cmx frames.cmi
+history.cmo : primitives.cmi int64ops.cmi debugger_config.cmi \
+    checkpoints.cmi history.cmi
+history.cmx : primitives.cmx int64ops.cmx debugger_config.cmx \
+    checkpoints.cmx history.cmi
+input_handling.cmo : $(UNIXDIR)/unix.cmi primitives.cmi \
     input_handling.cmi
-input_handling.cmx: $(UNIXDIR)/unix.cmx primitives.cmx \
+input_handling.cmx : $(UNIXDIR)/unix.cmx primitives.cmx \
     input_handling.cmi
-int64ops.cmo: int64ops.cmi
-int64ops.cmx: int64ops.cmi
-lexer.cmo: parser.cmi lexer.cmi
-lexer.cmx: parser.cmx lexer.cmi
-loadprinter.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \
+int64ops.cmo : int64ops.cmi
+int64ops.cmx : int64ops.cmi
+lexer.cmo : parser.cmi lexer.cmi
+lexer.cmx : parser.cmx lexer.cmi
+loadprinter.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \
     ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \
     ../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \
     dynlink.cmi ../typing/ctype.cmi ../utils/config.cmi loadprinter.cmi
-loadprinter.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \
+loadprinter.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \
     ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \
     ../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \
     dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi
-main.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \
+main.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \
     show_information.cmi question.cmi program_management.cmi primitives.cmi \
     parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \
     ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \
     command_line.cmi ../utils/clflags.cmi checkpoints.cmi
-main.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \
+main.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \
     show_information.cmx question.cmx program_management.cmx primitives.cmx \
     parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \
     ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \
     command_line.cmx ../utils/clflags.cmx checkpoints.cmx
-parameters.cmo: primitives.cmi envaux.cmi debugger_config.cmi \
+parameters.cmo : primitives.cmi envaux.cmi debugger_config.cmi \
     ../utils/config.cmi parameters.cmi
-parameters.cmx: primitives.cmx envaux.cmx debugger_config.cmx \
+parameters.cmx : primitives.cmx envaux.cmx debugger_config.cmx \
     ../utils/config.cmx parameters.cmi
-parser.cmo: parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \
+parser.cmo : parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \
     input_handling.cmi parser.cmi
-parser.cmx: parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \
+parser.cmx : parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \
     input_handling.cmx parser.cmi
-pattern_matching.cmo: ../typing/typedtree.cmi parser_aux.cmi \
+pattern_matching.cmo : ../typing/typedtree.cmi parser_aux.cmi \
     ../utils/misc.cmi debugger_config.cmi debugcom.cmi ../typing/ctype.cmi \
     pattern_matching.cmi
-pattern_matching.cmx: ../typing/typedtree.cmx parser_aux.cmi \
+pattern_matching.cmx : ../typing/typedtree.cmx parser_aux.cmi \
     ../utils/misc.cmx debugger_config.cmx debugcom.cmx ../typing/ctype.cmx \
     pattern_matching.cmi
-pos.cmo: source.cmi primitives.cmi ../parsing/location.cmi \
+pos.cmo : source.cmi primitives.cmi ../parsing/location.cmi \
     ../bytecomp/instruct.cmi pos.cmi
-pos.cmx: source.cmx primitives.cmx ../parsing/location.cmx \
+pos.cmx : source.cmx primitives.cmx ../parsing/location.cmx \
     ../bytecomp/instruct.cmx pos.cmi
-primitives.cmo: $(UNIXDIR)/unix.cmi primitives.cmi
-primitives.cmx: $(UNIXDIR)/unix.cmx primitives.cmi
-printval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi \
+primitives.cmo : $(UNIXDIR)/unix.cmi primitives.cmi
+primitives.cmx : $(UNIXDIR)/unix.cmx primitives.cmi
+printval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi \
     ../typing/printtyp.cmi ../typing/path.cmi parser_aux.cmi \
     ../typing/outcometree.cmi ../typing/oprint.cmi \
     ../toplevel/genprintval.cmi debugcom.cmi printval.cmi
-printval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx \
+printval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx \
     ../typing/printtyp.cmx ../typing/path.cmx parser_aux.cmi \
     ../typing/outcometree.cmi ../typing/oprint.cmx \
     ../toplevel/genprintval.cmx debugcom.cmx printval.cmi
-program_loading.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi primitives.cmi \
-    parameters.cmi input_handling.cmi debugger_config.cmi program_loading.cmi
-program_loading.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx primitives.cmx \
-    parameters.cmx input_handling.cmx debugger_config.cmx program_loading.cmi
-program_management.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \
+program_loading.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \
+    primitives.cmi parameters.cmi input_handling.cmi debugger_config.cmi \
+    program_loading.cmi
+program_loading.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \
+    primitives.cmx parameters.cmx input_handling.cmx debugger_config.cmx \
+    program_loading.cmi
+program_management.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \
     time_travel.cmi symbols.cmi question.cmi program_loading.cmi \
     primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \
     debugger_config.cmi breakpoints.cmi program_management.cmi
-program_management.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \
+program_management.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \
     time_travel.cmx symbols.cmx question.cmx program_loading.cmx \
     primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \
     debugger_config.cmx breakpoints.cmx program_management.cmi
-question.cmo: primitives.cmi lexer.cmi input_handling.cmi question.cmi
-question.cmx: primitives.cmx lexer.cmx input_handling.cmx question.cmi
-show_information.cmo: symbols.cmi source.cmi show_source.cmi printval.cmi \
+question.cmo : primitives.cmi lexer.cmi input_handling.cmi question.cmi
+question.cmx : primitives.cmx lexer.cmx input_handling.cmx question.cmi
+show_information.cmo : symbols.cmi source.cmi show_source.cmi printval.cmi \
     ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \
     debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi
-show_information.cmx: symbols.cmx source.cmx show_source.cmx printval.cmx \
+show_information.cmx : symbols.cmx source.cmx show_source.cmx printval.cmx \
     ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \
     debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi
-show_source.cmo: source.cmi primitives.cmi parameters.cmi \
+show_source.cmo : source.cmi primitives.cmi parameters.cmi \
     ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \
     debugger_config.cmi show_source.cmi
-show_source.cmx: source.cmx primitives.cmx parameters.cmx \
+show_source.cmx : source.cmx primitives.cmx parameters.cmx \
     ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \
     debugger_config.cmx show_source.cmi
-source.cmo: primitives.cmi ../utils/misc.cmi debugger_config.cmi \
+source.cmo : primitives.cmi ../utils/misc.cmi debugger_config.cmi \
     ../utils/config.cmi source.cmi
-source.cmx: primitives.cmx ../utils/misc.cmx debugger_config.cmx \
+source.cmx : primitives.cmx ../utils/misc.cmx debugger_config.cmx \
     ../utils/config.cmx source.cmi
-symbols.cmo: ../bytecomp/symtable.cmi program_loading.cmi \
+symbols.cmo : ../bytecomp/symtable.cmi program_loading.cmi \
     ../bytecomp/instruct.cmi events.cmi debugger_config.cmi debugcom.cmi \
     checkpoints.cmi ../bytecomp/bytesections.cmi symbols.cmi
-symbols.cmx: ../bytecomp/symtable.cmx program_loading.cmx \
+symbols.cmx : ../bytecomp/symtable.cmx program_loading.cmx \
     ../bytecomp/instruct.cmx events.cmx debugger_config.cmx debugcom.cmx \
     checkpoints.cmx ../bytecomp/bytesections.cmx symbols.cmi
-time_travel.cmo: trap_barrier.cmi symbols.cmi question.cmi \
+time_travel.cmo : trap_barrier.cmi symbols.cmi question.cmi \
     program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \
     ../bytecomp/instruct.cmi input_handling.cmi exec.cmi events.cmi \
     debugger_config.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \
     time_travel.cmi
-time_travel.cmx: trap_barrier.cmx symbols.cmx question.cmx \
+time_travel.cmx : trap_barrier.cmx symbols.cmx question.cmx \
     program_loading.cmx primitives.cmx ../utils/misc.cmx int64ops.cmx \
     ../bytecomp/instruct.cmx input_handling.cmx exec.cmx events.cmx \
     debugger_config.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \
     time_travel.cmi
-trap_barrier.cmo: exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi
-trap_barrier.cmx: exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi
-unix_tools.cmo: $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \
+trap_barrier.cmo : exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi
+trap_barrier.cmx : exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi
+unix_tools.cmo : $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \
     unix_tools.cmi
-unix_tools.cmx: $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \
+unix_tools.cmx : $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \
     unix_tools.cmi

diff --git a/debugger/.ignore b/debugger/.ignore
new file mode 100644 (file)
index 0000000..45440f8
--- /dev/null
+++ b/debugger/.ignore
@@ -0,0 +1,6 @@
+lexer.ml
+parser.ml
+parser.mli
+ocamldebug
+dynlink.ml
+dynlink.mli

diff --git a/debugger/Makefile b/debugger/Makefile
index 3ff1b54aa457dda26a8613b45723d8a4967401cd..2e6534c7303668020f69f862c377112c13a7daef 100644 (file)
--- a/debugger/Makefile
+++ b/debugger/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/debugger/Makefile.nt b/debugger/Makefile.nt
index 70263e94d87ad31f56b74a2d658cd7921ece3bef..40034ef482a51ee1d27ff35c3057ee34d8389ab4 100644 (file)
--- a/debugger/Makefile.nt
+++ b/debugger/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared
index 778fcf11292849f005d96d183cb997ad4be0e6cf..820af9af9ebf9d3388c016bd63026e72f549d909 100644 (file)
--- a/debugger/Makefile.shared
+++ b/debugger/Makefile.shared
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -29,9 +29,9 @@ INCLUDES=\
 
 OTHEROBJS=\
   $(UNIXDIR)/unix.cma \
-  ../utils/misc.cmo ../utils/config.cmo \
-  ../utils/tbl.cmo ../utils/clflags.cmo ../utils/consistbl.cmo \
-  ../parsing/longident.cmo \
+  ../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \
+  ../utils/clflags.cmo ../utils/consistbl.cmo ../utils/warnings.cmo \
+  ../parsing/location.cmo ../parsing/longident.cmo \
   ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \
   ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \
   ../typing/subst.cmo ../typing/predef.cmo \

diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml
index 1da4b74e2654796a3ad07f2e8313bd49daeacbed..5e84cc6ca6a72dc4938a0c0d772fd77736897775 100644 (file)
--- a/debugger/breakpoints.ml
+++ b/debugger/breakpoints.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/breakpoints.mli b/debugger/breakpoints.mli
index 091f609981f680b95e4c0072699575413c1f1412..855ef5e17bf7dadc4b670acd2474feb065d8ca01 100644 (file)
--- a/debugger/breakpoints.mli
+++ b/debugger/breakpoints.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/checkpoints.ml b/debugger/checkpoints.ml
index ffcff35e3697f2bd12f95446da3049b29351f0ed..e2371f17045b708846b5e5a6e7a44c73de5fa083 100644 (file)
--- a/debugger/checkpoints.ml
+++ b/debugger/checkpoints.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/checkpoints.mli b/debugger/checkpoints.mli
index 17c1037aa21a294bf62dfab3c1cf9ba9c4d0aca3..b37d1ae55eda22362a67392abd8226d980530dd6 100644 (file)
--- a/debugger/checkpoints.mli
+++ b/debugger/checkpoints.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/command_line.ml b/debugger/command_line.ml
index 944efa864c6d2783046d1c7df77f1f176d2e24fb..9b0084daf29a164e4a56d64c792de4e3ebde12f7 100644 (file)
--- a/debugger/command_line.ml
+++ b/debugger/command_line.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -230,6 +230,22 @@ let instr_shell ppf lexbuf =
   if (err != 0) then
     eprintf "Shell command %S failed with exit code %d\n%!" cmd err
 
+let instr_env ppf lexbuf =
+  let cmdarg = argument_list_eol argument lexbuf in
+  let cmdarg = string_trim (String.concat " " cmdarg) in
+  if cmdarg <> "" then
+    try
+      if (String.index cmdarg '=') > 0 then
+       Debugger_config.environment := cmdarg :: !Debugger_config.environment
+      else
+       eprintf "Environment variables should not have an empty name\n%!"
+    with Not_found ->
+      eprintf "Environment variables should have the \"name=value\" format\n%!"
+  else
+    List.iter
+      (printf "%s\n%!")
+      (List.rev !Debugger_config.environment)
+
 let instr_pwd ppf lexbuf =
   eol lexbuf;
   fprintf ppf "%s@." (Sys.getcwd ())
@@ -454,7 +470,7 @@ let instr_help ppf lexbuf =
           fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l
       end
   | None ->
-      fprintf ppf "List of commands :%a@." pr_instrs !instruction_list
+      fprintf ppf "List of commands : %a@." pr_instrs !instruction_list
 
 (* Printing values *)
 
@@ -962,6 +978,9 @@ With no argument, reset the search path." };
      { instr_name = "shell"; instr_prio = false;
        instr_action = instr_shell; instr_repeat = true; instr_help =
 "Execute a given COMMAND thru the system shell." };
+     { instr_name = "environment"; instr_prio = false;
+       instr_action = instr_env; instr_repeat = false; instr_help =
+"environment variable to give to program being debugged when it is started." };
       (* Displacements *)
      { instr_name = "run"; instr_prio = true;
        instr_action = instr_run; instr_repeat = true; instr_help =

diff --git a/debugger/command_line.mli b/debugger/command_line.mli
index dd2349d2c4d4729833dd9c8333c36eb7bbe688bd..422cf6a2422233773c9d2e247b7315a9c5af9c4c 100644 (file)
--- a/debugger/command_line.mli
+++ b/debugger/command_line.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml
index dfe905bac4bf7dabbcb75fd3d000e4c97f8afde6..1da00cbab86d00281476229b5305e3ed18750a97 100644 (file)
--- a/debugger/debugcom.ml
+++ b/debugger/debugcom.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -189,8 +189,7 @@ let set_trap_barrier pos =
 let value_size = if 1 lsl 31 = 0 then 4 else 8
 
 let input_remote_value ic =
-  let v = String.create value_size in
-  really_input ic v 0 value_size; v
+  Misc.input_bytes ic value_size
 
 let output_remote_value ic v =
   output ic v 0 value_size
@@ -247,8 +246,7 @@ module Remote_value =
           if input_byte !conn.io_in = 0 then
             Remote(input_remote_value !conn.io_in)
           else begin
-            let buf = String.create 8 in
-            really_input !conn.io_in buf 0 8;
+            let buf = Misc.input_bytes !conn.io_in 8 in
             let floatbuf = float n (* force allocation of a new float *) in
             String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8;
             Local(Obj.repr floatbuf)

diff --git a/debugger/debugcom.mli b/debugger/debugcom.mli
index abf4fd0b2c9fa3dc0dcfa3a325773ecc05645eb2..7d107ac5b81ef1fc0849ccf266e971e40aaf20f4 100644 (file)
--- a/debugger/debugcom.mli
+++ b/debugger/debugcom.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml
index 54d6b2d58390242fc59ecd50a7d04262c89349b3..29287593659f93aaffc2675506f53e8b8f67704a 100644 (file)
--- a/debugger/debugger_config.ml
+++ b/debugger/debugger_config.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -56,7 +56,7 @@ let shell =
     "Win32" -> "cmd"
   | _ -> "/bin/sh"
 
-(* Name of the Objective Caml runtime. *)
+(* Name of the OCaml runtime. *)
 let runtime_program = "ocamlrun"
 
 (* Time history size (for `last') *)
@@ -80,3 +80,7 @@ let make_checkpoints = ref
   (match Sys.os_type with
     "Win32" -> false
   | _ -> true)
+
+(*** Environment variables for debugee. ***)
+
+let environment = ref []

diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli
index 18faf9c62f6c94b322acb511c9d20e68a25508da..d3f1a2a7d9916b4af6ff683858257f715ba35f1f 100644 (file)
--- a/debugger/debugger_config.mli
+++ b/debugger/debugger_config.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -33,3 +33,7 @@ val checkpoint_big_step : int64 ref
 val checkpoint_small_step : int64 ref
 val checkpoint_max_count : int ref
 val make_checkpoints : bool ref
+
+(*** Environment variables for debugee. ***)
+
+val environment : string list ref

diff --git a/debugger/envaux.ml b/debugger/envaux.ml
index 8d462e2f874abdb4203829f2de6950caadd2e8df..56786929ebbb99739baa43eff0a096445929263b 100644 (file)
--- a/debugger/envaux.ml
+++ b/debugger/envaux.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/envaux.mli b/debugger/envaux.mli
index 8b122cc347aa74d3379dbcb4457c620761f9b240..b78173c4a7f9a3ae9bdfe0fc1df0dd77b7ff0937 100644 (file)
--- a/debugger/envaux.mli
+++ b/debugger/envaux.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/eval.ml b/debugger/eval.ml
index 7ee1339f010f0dbcc6fcc3f3f6bbdadcb9566c65..0f8c8a056675b28079f6bdb78dcf049f29641923 100644 (file)
--- a/debugger/eval.ml
+++ b/debugger/eval.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/eval.mli b/debugger/eval.mli
index b2a2998f149d612349ec4c14d0094f1566dfefb2..96661b2a3c71fc48ca99dee7f28c5462e7e6e18f 100644 (file)
--- a/debugger/eval.mli
+++ b/debugger/eval.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/events.ml b/debugger/events.ml
index 2521c064dbe82506b1253626cf5ac7c343f7e9ef..78733bfc4efbca9f88accc43ba1c38c0d31ab6cb 100644 (file)
--- a/debugger/events.ml
+++ b/debugger/events.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/events.mli b/debugger/events.mli
index 7166f2c9d0fa185fad8e2c51a29c5f40bca33a17..f795058cc7c9bf48db8ad607082e113e7a2739ec 100644 (file)
--- a/debugger/events.mli
+++ b/debugger/events.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/exec.ml b/debugger/exec.ml
index 1ea165978fc9a41abc4bfcb9293a526d6003ec47..22d281bcc33d7b4a9bf5289e0699423542520f40 100644 (file)
--- a/debugger/exec.ml
+++ b/debugger/exec.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/exec.mli b/debugger/exec.mli
index 9d3b98604848086c9aff7f369db05180208c7fe7..c9d665ae05429541f5a59adedd6439dc220beb8c 100644 (file)
--- a/debugger/exec.mli
+++ b/debugger/exec.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/frames.ml b/debugger/frames.ml
index c533782fc4e0020c914856180bbef5eb46931ce0..2a87ffdd8d5303020c4196acf5aad9d47397e3e2 100644 (file)
--- a/debugger/frames.ml
+++ b/debugger/frames.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/frames.mli b/debugger/frames.mli
index b4863433ddc653f817943f4cc802b69bf0ad693d..5023236cb8c6dd5f3fd90f86bf4b6a68f351df67 100644 (file)
--- a/debugger/frames.mli
+++ b/debugger/frames.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/history.ml b/debugger/history.ml
index e8c5ed8ff5b029326345b72d413be57718a870e4..473ba80bb02db273b5a930164e48b4c31e214aa1 100644 (file)
--- a/debugger/history.ml
+++ b/debugger/history.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/history.mli b/debugger/history.mli
index 249629fdb9aa1ab865c1d69cafa8957a21e0ddd7..542b9ca04715c2f3e57604c6c97ac009a6fe1e7c 100644 (file)
--- a/debugger/history.mli
+++ b/debugger/history.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml
index f25d474266cbd5aad69d2cf369b70cacab593396..8bbc0d80f515eebe0fb122ce96eeaf54f14b7447 100644 (file)
--- a/debugger/input_handling.ml
+++ b/debugger/input_handling.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/input_handling.mli b/debugger/input_handling.mli
index 959547df79ec1443394abb9d7d36d47066689035..7ae190ee1bc7ab1047611af2e016a8e513b9ff88 100644 (file)
--- a/debugger/input_handling.mli
+++ b/debugger/input_handling.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/int64ops.ml b/debugger/int64ops.ml
index b854a6c34319cb042a6a419dbda17159bab85e88..a3dbdbe2cc90e9458c055def531731f96f6446a5 100644 (file)
--- a/debugger/int64ops.ml
+++ b/debugger/int64ops.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocqencourt          *)
 (*                                                                     *)

diff --git a/debugger/int64ops.mli b/debugger/int64ops.mli
index 98f7228d3d25e2ac80df2f33604fd5c9c6c289e9..f898f1431b7ce170dddc0ee82647222699bb2a3d 100644 (file)
--- a/debugger/int64ops.mli
+++ b/debugger/int64ops.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocqencourt          *)
 (*                                                                     *)

diff --git a/debugger/lexer.mli b/debugger/lexer.mli
index 7214ed2be94e97d0beb997da524ff5512cfc3eae..23f88e571f83da5df7a45618cd684d60279b2d9e 100644 (file)
--- a/debugger/lexer.mli
+++ b/debugger/lexer.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/lexer.mll b/debugger/lexer.mll
index eea8ed02843f2ff6303f79a3ecb94079cee329ef..7dd51e70470e15d5c5fbe4033ba7e2b93d3e3da3 100644 (file)
--- a/debugger/lexer.mll
+++ b/debugger/lexer.mll
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml
index ac5aa0187df9f4ff02890898cca3ffe8024687f6..0395cfb307a0a9565305a2e15b48c00281fb2398 100644 (file)
--- a/debugger/loadprinter.ml
+++ b/debugger/loadprinter.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -106,7 +106,7 @@ let match_printer_type desc typename =
   let ty_arg = Ctype.newvar() in
   Ctype.unify Env.empty
     (Ctype.newconstr printer_type [ty_arg])
-    (Ctype.instance desc.val_type);
+    (Ctype.instance Env.empty desc.val_type);
   Ctype.end_def();
   Ctype.generalize ty_arg;
   ty_arg

diff --git a/debugger/loadprinter.mli b/debugger/loadprinter.mli
index bdaf77a28522cf196c8dd01a0b1d771c194e8b4f..77edfc53dc958661935e218103d28c9d99d817d0 100644 (file)
--- a/debugger/loadprinter.mli
+++ b/debugger/loadprinter.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/debugger/main.ml b/debugger/main.ml
index f5f0d8b5565a6651fb210780b992fe3c250cfa5e..9dbb41ee60dd902f59318f102d1a5f947e59ccc2 100644 (file)
--- a/debugger/main.ml
+++ b/debugger/main.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -158,7 +158,7 @@ let set_checkpoints n =
 let set_directory dir =
   Sys.chdir dir
 let print_version () =
-  printf "The Objective Caml debugger, version %s@." Sys.ocaml_version;
+  printf "The OCaml debugger, version %s@." Sys.ocaml_version;
   exit 0;
 ;;
 let print_version_num () =
@@ -183,7 +183,11 @@ let speclist = [
       " Print version number and exit";
    ]
 
+let function_placeholder () =
+  raise Not_found
+
 let main () =
+  Callback.register "Debugger.function_placeholder" function_placeholder;
   try
     socket_name :=
       (match Sys.os_type with
@@ -206,7 +210,7 @@ let main () =
         arguments := !arguments ^ " " ^ (Filename.quote Sys.argv.(j))
       done
     end;
-    printf "\tObjective Caml Debugger version %s@.@." Config.version;
+    printf "\tOCaml Debugger version %s@.@." Config.version;
     Config.load_path := !default_load_path;
     Clflags.recursive_types := true;    (* Allow recursive types. *)
     toplevel_loop ();                   (* Toplevel. *)

diff --git a/debugger/parameters.ml b/debugger/parameters.ml
index 9d518e54941fec11a6e7bfc18e713302bed2ccd4..fb816e4d5d913b42ada39f460a14c5f4a0d9a06e 100644 (file)
--- a/debugger/parameters.ml
+++ b/debugger/parameters.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/parameters.mli b/debugger/parameters.mli
index 8f750e68a6e61c586b37dae737012694996f8bae..eb055f7c5d4b42a80de4c320c09ea8f290f7eccf 100644 (file)
--- a/debugger/parameters.mli
+++ b/debugger/parameters.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/parser.mly b/debugger/parser.mly
index 6fc8392a86a56e9fa8e71859a75a262aea5281ec..5bba611b9da3434e9714c0c306a552524a3fbf8b 100644 (file)
--- a/debugger/parser.mly
+++ b/debugger/parser.mly
@@ -1,9 +1,9 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        */
-/*          Objective Caml port by John Malecki and Xavier Leroy       */
+/*          OCaml port by John Malecki and Xavier Leroy                */
 /*                                                                     */
 /*  Copyright 1996 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
@@ -170,6 +170,8 @@ longident :
     LIDENT                      { Lident $1 }
   | module_path DOT LIDENT      { Ldot($1, $3) }
   | OPERATOR                    { Lident $1 }
+  | module_path DOT OPERATOR    { Ldot($1, $3) }
+  | module_path DOT LPAREN OPERATOR RPAREN { Ldot($1, $4) }
 ;
 
 module_path :

diff --git a/debugger/parser_aux.mli b/debugger/parser_aux.mli
index a68e08d5c8727d260255696da3a78c01625dcb75..275281cc49434943a09cad5aecccf6fbbaa111fd 100644 (file)
--- a/debugger/parser_aux.mli
+++ b/debugger/parser_aux.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/pattern_matching.ml b/debugger/pattern_matching.ml
index 97af9326b5139c865cb334207878d6c0aa26d74c..b921182657374a1192eb2bde3c2b64fd4e33aa22 100644 (file)
--- a/debugger/pattern_matching.ml
+++ b/debugger/pattern_matching.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/pattern_matching.mli b/debugger/pattern_matching.mli
index 3490edef69239c8270e78b171396d55fc618dd8d..a7a525622bcdf7f2e0c3246089fd41f62eb5f06c 100644 (file)
--- a/debugger/pattern_matching.mli
+++ b/debugger/pattern_matching.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/pos.ml b/debugger/pos.ml
index 4beba3de0fcf2540b15f94285b339dc8415c5f6d..9951686481c84b2613b26cbe35df6874f16c6073 100644 (file)
--- a/debugger/pos.ml
+++ b/debugger/pos.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,23 +20,8 @@ open Source;;
 
 let get_desc ev =
   let loc = ev.ev_loc in
-  if loc.loc_start.pos_fname <> ""
-  then Printf.sprintf "file %s, line %d, characters %d-%d"
-                      loc.loc_start.pos_fname loc.loc_start.pos_lnum
-                      (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1)
-                      (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1)
-  else begin
-    let filename = source_of_module ev.ev_loc.loc_start ev.ev_module in
-    try
-      let (start, line) = line_of_pos (get_buffer loc.loc_start ev.ev_module)
-                                      loc.loc_start.pos_cnum
-      in
-      Printf.sprintf "file %s, line %d, characters %d-%d"
-                     filename line (loc.loc_start.pos_cnum - start + 1)
-                     (loc.loc_end.pos_cnum - start + 1)
-    with Not_found | Out_of_range ->
-      Printf.sprintf "file %s, characters %d-%d"
-                     filename (loc.loc_start.pos_cnum + 1)
-                     (loc.loc_end.pos_cnum + 1)
-  end
+  Printf.sprintf "file %s, line %d, characters %d-%d"
+                 loc.loc_start.pos_fname loc.loc_start.pos_lnum
+                 (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1)
+                 (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1)
 ;;

diff --git a/debugger/pos.mli b/debugger/pos.mli
index e7632e4274c6c707cdc1f7c27762f1a8a5016234..a4c8e9e8d5b2cace35df6f885e109b16681a7ad7 100644 (file)
--- a/debugger/pos.mli
+++ b/debugger/pos.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/debugger/primitives.ml b/debugger/primitives.ml
index d4ba22e5f8f75ec54e9205668a05df2b40c89457..bfd2fdd8de654c222a48f8f6b5a98c1ef5ccae34 100644 (file)
--- a/debugger/primitives.ml
+++ b/debugger/primitives.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/primitives.mli b/debugger/primitives.mli
index 4333128fb66e98ed4addedb2e3c80140f8776223..4d914da9842504404773ce0c526aef2d1c0152c6 100644 (file)
--- a/debugger/primitives.mli
+++ b/debugger/primitives.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/printval.ml b/debugger/printval.ml
index 5f36e1a7cc52b1116e3384cca1e44d18ea459b2e..84a0f06e41614d27db0bbaaaf2223c4e6e71e989 100644 (file)
--- a/debugger/printval.ml
+++ b/debugger/printval.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/printval.mli b/debugger/printval.mli
index bb6318880c0e223a461940de898a8da50e29fdb3..f1c4569bb83b94db3874d4ed0d19d63bb7a376ff 100644 (file)
--- a/debugger/printval.mli
+++ b/debugger/printval.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml
index 79577ff4b9838169094cd8a885e15b6370716f37..bef9f80d173692fcc92d6c07fe8f3cb673c05950 100644 (file)
--- a/debugger/program_loading.ml
+++ b/debugger/program_loading.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -35,6 +35,39 @@ let load_program () =
 
 (*** Launching functions. ***)
 
+(* Returns the environment to be passed to debugee *)
+let get_environment () =
+  let env = Unix.environment () in
+  let have_same_name x y =
+    let split = Primitives.split_string '=' in
+    match split x, split y with
+      (hd1 :: _), (hd2 :: _) -> hd1 = hd2
+    | _ -> false in
+  let have_name_in_config_env x =
+    List.exists
+      (have_same_name x)
+      !Debugger_config.environment in
+  let env =
+    Array.fold_right
+      (fun elem acc ->
+        if have_name_in_config_env elem then
+          acc
+        else
+          elem :: acc)
+      env
+      [] in
+  Array.of_list (env @ !Debugger_config.environment)
+
+(* Returns the environment to be passed to debugee *)
+let get_win32_environment () =
+  let res = Buffer.create 256 in
+  let env = get_environment () in
+  let len = Array.length env in
+  for i = 0 to pred len do
+    Buffer.add_string res (Printf.sprintf "set %s && " env.(i))
+  done;
+  Buffer.contents res
+
 (* A generic function for launching the program *)
 let generic_exec_unix cmdline = function () ->
   if !debug_loading then
@@ -52,7 +85,7 @@ let generic_exec_unix cmdline = function () ->
            0 -> (* Try to detach the process from the controlling terminal,
                    so that it does not receive SIGINT on ctrl-C. *)
                 begin try ignore(setsid()) with Invalid_argument _ -> () end;
-                execv shell [| shell; "-c"; cmdline() |]
+                execve shell [| shell; "-c"; cmdline() |] (get_environment ())
          | _ -> exit 0
        with x ->
          Unix_tools.report_error x;
@@ -76,7 +109,7 @@ let generic_exec =
     "Win32" -> generic_exec_win
   | _ -> generic_exec_unix
 
-(* Execute the program by calling the runtime explicitely *)
+(* Execute the program by calling the runtime explicitly *)
 let exec_with_runtime =
   generic_exec
     (function () ->
@@ -86,7 +119,8 @@ let exec_with_runtime =
              but quoting is even worse because Unix.create_process
              thinks each command line parameter is a file.
              So no good solution so far *)
-          Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s %s"
+          Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s %s"
+                     (get_win32_environment ())
                      !socket_name
                      runtime_program
                      !program_name
@@ -105,7 +139,8 @@ let exec_direct =
       match Sys.os_type with
         "Win32" ->
           (* See the comment above *)
-          Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s"
+          Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s"
+                     (get_win32_environment ())
                      !socket_name
                      !program_name
                      !arguments

diff --git a/debugger/program_loading.mli b/debugger/program_loading.mli
index d1210d1ab0d683febb507dbd882748cab7c65e18..2814eb39cfd6fd111fcce37026762f7e0796da0f 100644 (file)
--- a/debugger/program_loading.mli
+++ b/debugger/program_loading.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/program_management.ml b/debugger/program_management.ml
index 8ebb907d1fa56a6ee9180ffa9a618b210e0e1f45..3e6ffa81d153a094c23a81acfee9e97871b10737 100644 (file)
--- a/debugger/program_management.ml
+++ b/debugger/program_management.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/program_management.mli b/debugger/program_management.mli
index 8e2f28e54ec71468125c1c6c08eb73406130b8c5..96f5a4382408b44947c1a4d76141cad55340afed 100644 (file)
--- a/debugger/program_management.mli
+++ b/debugger/program_management.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/question.ml b/debugger/question.ml
index 2eeec3ab0d9deda06ee523201ba7efb5980e5bc8..f17227b9be3d6c65c4150f6d0dfeda163ebbbbae 100644 (file)
--- a/debugger/question.ml
+++ b/debugger/question.ml
@@ -1,3 +1,15 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2006 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 open Input_handling
 open Primitives
 

diff --git a/debugger/question.mli b/debugger/question.mli
index 3a92dee6b26e9e0035f24bec7f1d0854ca80be46..d8e50ef9b8bc6ea39c1a79e6fa9116aa1ebf53e0 100644 (file)
--- a/debugger/question.mli
+++ b/debugger/question.mli
@@ -1,2 +1,14 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2006 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* Ask user a yes or no question. *)
 val yes_or_no : string -> bool

diff --git a/debugger/show_information.ml b/debugger/show_information.ml
index bd746eb7f85566eb3a432ad6af1fa9f86d378fe1..86e9637a49c4bb4af3ea82a15a112928e29d1819 100644 (file)
--- a/debugger/show_information.ml
+++ b/debugger/show_information.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/show_information.mli b/debugger/show_information.mli
index 3069f93321db3be5e18503554f96bb1a3530e46a..7774721a94c47a70412ef95c8d43e0183b4fd918 100644 (file)
--- a/debugger/show_information.mli
+++ b/debugger/show_information.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/show_source.ml b/debugger/show_source.ml
index 2826c9e686dc09438ac15b7d19b30dd24595259a..4a998f5201968400ddf51bdf36dad1bdd3055cd6 100644 (file)
--- a/debugger/show_source.ml
+++ b/debugger/show_source.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/show_source.mli b/debugger/show_source.mli
index 5ba418af583bb081efce337ad95cda5319b74cb2..3b136ab7471f08cfd9b1510328bf53e9f101db55 100644 (file)
--- a/debugger/show_source.mli
+++ b/debugger/show_source.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/source.ml b/debugger/source.ml
index f0d3d48fb9ce4ed7a67c691a58d681094b17df66..0f705f25989c356e6aeabf47975a224576c8f24b 100644 (file)
--- a/debugger/source.ml
+++ b/debugger/source.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -39,20 +39,7 @@ let source_of_module pos mdle =
       Debugger_config.load_path_for
       !Config.load_path in
   let fname = pos.Lexing.pos_fname in
-  if fname = "" then
-    let innermost_module =
-      try
-        let dot_index = String.rindex mdle '.' in
-        String.sub mdle (succ dot_index) (pred ((String.length mdle) - dot_index))
-      with Not_found -> mdle in
-    let rec loop =
-      function
-      | [] -> raise Not_found
-      | ext :: exts ->
-          try find_in_path_uncap path (innermost_module ^ ext)
-          with Not_found -> loop exts
-    in loop source_extensions
-  else if Filename.is_implicit fname then
+  if Filename.is_implicit fname then
     find_in_path path fname
   else
     fname
@@ -76,13 +63,11 @@ let get_buffer pos mdle =
   try List.assoc mdle !buffer_list with
     Not_found ->
       let inchan = open_in_bin (source_of_module pos mdle) in
-        let (content, _) as buffer =
-          (String.create (in_channel_length inchan), ref [])
-        in
-          unsafe_really_input inchan content 0 (in_channel_length inchan);
-          buffer_list :=
-            (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list));
-          buffer
+      let content = Misc.input_bytes inchan (in_channel_length inchan) in
+      let buffer = (content, ref []) in
+      buffer_list :=
+        (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list));
+      buffer
 
 let buffer_content =
   (fst : buffer -> string)

diff --git a/debugger/source.mli b/debugger/source.mli
index 273cb517b34c3c4f03933922e4f97aa441c66a18..50fa3f02ad2d03053a8a7e935287a399504f08f4 100644 (file)
--- a/debugger/source.mli
+++ b/debugger/source.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/symbols.ml b/debugger/symbols.ml
index 392da976aa3227fd6828da2961469e3242938022..9fba3e09c84a25a73406d33b3c97c8ae2ffaf189 100644 (file)
--- a/debugger/symbols.ml
+++ b/debugger/symbols.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/symbols.mli b/debugger/symbols.mli
index 57ac8007b1b958c16d3247c223c91a0f4fdcb542..8823abd29c976ac5cd5ede240e7309b7ea6dad26 100644 (file)
--- a/debugger/symbols.mli
+++ b/debugger/symbols.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml
index a4a4c83fa0c1f74dcd08934f460486a122d60c6d..e10e0396952f8b6f207ea34582930553317f453d 100644 (file)
--- a/debugger/time_travel.ml
+++ b/debugger/time_travel.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/time_travel.mli b/debugger/time_travel.mli
index 453e4df05248d46120bedd99b1e50c73be26a800..dad47fedcafa3ff19305e85144633a89b5aeba48 100644 (file)
--- a/debugger/time_travel.mli
+++ b/debugger/time_travel.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/trap_barrier.ml b/debugger/trap_barrier.ml
index dba9c929f702e182742ec03a7df13e20023713db..6aa22b267c6bc15773c1764412d57a9b1b4c0a25 100644 (file)
--- a/debugger/trap_barrier.ml
+++ b/debugger/trap_barrier.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/trap_barrier.mli b/debugger/trap_barrier.mli
index 28bba5a3ebdafd5b305461b561f6c0c5a763a882..b12391af630cb31ca5a06ffd4019b73c768e5ffc 100644 (file)
--- a/debugger/trap_barrier.mli
+++ b/debugger/trap_barrier.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml
index 9926e05d5a497bd05015bd822936d40e43e50d86..dea47f99f8e319fa16e894a61bc9cfe2249d4959 100644 (file)
--- a/debugger/unix_tools.ml
+++ b/debugger/unix_tools.ml
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/debugger/unix_tools.mli b/debugger/unix_tools.mli
index b5e4ee6ca483387b4a7ac6824eb38ff3dc265392..bbea8447e0d5f94176237d0831f9517fdce206e0 100644 (file)
--- a/debugger/unix_tools.mli
+++ b/debugger/unix_tools.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
-(*          Objective Caml port by John Malecki and Xavier Leroy       *)
+(*          OCaml port by John Malecki and Xavier Leroy                *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/driver/compile.ml b/driver/compile.ml
index 4e2d8566ec07bdf089d2461a54930fc64a941460..cf9c2a4a3c6f2e818160917fae68522c8827c944 100644 (file)
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -116,9 +116,13 @@ let implementation ppf sourcefile outputprefix =
     try ignore(
       Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
-      ++ Typemod.type_implementation sourcefile outputprefix modulename env)
+      ++ Typemod.type_implementation sourcefile outputprefix modulename env);
+      Warnings.check_fatal ();
+      Pparse.remove_preprocessed inputfile;
+      Stypes.dump (outputprefix ^ ".annot");
     with x ->
       Pparse.remove_preprocessed_if_ast inputfile;
+      Stypes.dump (outputprefix ^ ".annot");
       raise x
   end else begin
     let objfile = outputprefix ^ ".cmo" in
@@ -126,7 +130,6 @@ let implementation ppf sourcefile outputprefix =
     try
       Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
-      ++ Unused_var.warn ppf
       ++ Typemod.type_implementation sourcefile outputprefix modulename env
       ++ Translmod.transl_implementation modulename
       ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda

diff --git a/driver/compile.mli b/driver/compile.mli
index 507d61bbd77b75cac39c952f7b633dd7ce046659..779239a8cc000105405c41df39d2bbc1326a6c96 100644 (file)
--- a/driver/compile.mli
+++ b/driver/compile.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/driver/errors.ml b/driver/errors.ml
index 22dd1fc6a0b5681cdf27c056f889e6dd453e5397..9400e9ebc5af2586d82eb4ecec231328efcae786 100644 (file)
--- a/driver/errors.ml
+++ b/driver/errors.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/driver/errors.mli b/driver/errors.mli
index ac203a53ef4e9b822da2ac0a0d1cfb6a7d1e42ad..9f7020d08a3e9eea808afae6152009b5a2979cf8 100644 (file)
--- a/driver/errors.mli
+++ b/driver/errors.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/driver/main.ml b/driver/main.ml
index 09aa89655e7bb88f27d449be935f6557a3bcf7bc..94b024eaa52310bf3c636f4da6bd42d508be357c 100644 (file)
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -61,7 +61,7 @@ let process_file ppf name =
     raise(Arg.Bad("don't know what to do with " ^ name))
 
 let print_version_and_library () =
-  print_string "The Objective Caml compiler, version ";
+  print_string "The OCaml compiler, version ";
   print_string Config.version; print_newline();
   print_string "Standard library directory: ";
   print_string Config.standard_library; print_newline();
@@ -75,10 +75,12 @@ let print_standard_library () =
 
 let usage = "Usage: ocamlc <options> <files>\nOptions are:"
 
+let ppf = Format.err_formatter
+
 (* Error messages to standard error formatter *)
-let anonymous = process_file Format.err_formatter;;
-let impl = process_implementation_file Format.err_formatter;;
-let intf = process_interface_file Format.err_formatter;;
+let anonymous = process_file ppf;;
+let impl = process_implementation_file ppf;;
+let intf = process_interface_file ppf;;
 
 let show_config () =
   Config.print_config stdout;
@@ -89,6 +91,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let set r () = r := true
   let unset r () = r := false
   let _a = set make_archive
+  let _absname = set Location.absname
   let _annot = set annotations
   let _c = set compile_only
   let _cc s = c_compiler := Some s
@@ -119,6 +122,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _pp s = preprocessor := Some s
   let _principal = set principal
   let _rectypes = set recursive_types
+  let _runtime_variant s = runtime_variant := s
   let _strict_sequence = set strict_sequence
   let _thread = set use_threads
   let _vmthread = set use_vmthreads
@@ -165,16 +169,19 @@ let main () =
         fatal "Option -i is incompatible with -pack, -a, -output-obj"
       else
         fatal "Please specify at most one of -pack, -a, -c, -output-obj";
-
     if !make_archive then begin
       Compile.init_path();
-      Bytelibrarian.create_archive (List.rev !objfiles)
-                                   (extract_output !output_name)
+
+      Bytelibrarian.create_archive ppf  (List.rev !objfiles)
+                                   (extract_output !output_name);
+      Warnings.check_fatal ();
     end
     else if !make_package then begin
       Compile.init_path();
-      Bytepackager.package_files (List.rev !objfiles)
-                                 (extract_output !output_name)
+      let extracted_output = extract_output !output_name in
+      let revd = List.rev !objfiles in
+      Bytepackager.package_files ppf revd (extracted_output);
+      Warnings.check_fatal ();
     end
     else if not !compile_only && !objfiles <> [] then begin
       let target =
@@ -194,11 +201,12 @@ let main () =
           default_output !output_name
       in
       Compile.init_path();
-      Bytelink.link (List.rev !objfiles) target
+      Bytelink.link ppf (List.rev !objfiles) target;
+      Warnings.check_fatal ();
     end;
     exit 0
   with x ->
-    Errors.report_error Format.err_formatter x;
+    Errors.report_error ppf x;
     exit 2
 
 let _ = main ()

diff --git a/driver/main.mli b/driver/main.mli
index d175a3ca264478f0c70b0f6eb5d050645f86ff48..b949bb0fe9b29b8f5f9fe136cfa09cbb5903508d 100644 (file)
--- a/driver/main.mli
+++ b/driver/main.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/driver/main_args.ml b/driver/main_args.ml
index 279a46328ed5baa0ab42b6953dfe78d4cb609c85..75e3f164abba34cb58c8b07a2d2684d746883ecd 100644 (file)
--- a/driver/main_args.ml
+++ b/driver/main_args.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -16,6 +16,10 @@ let mk_a f =
   "-a", Arg.Unit f, " Build a library"
 ;;
 
+let mk_absname f =
+  "-absname", Arg.Unit f, "  Show absolute filenames in error message"
+;;
+
 let mk_annot f =
   "-annot", Arg.Unit f, " Save information in <filename>.annot"
 ;;
@@ -165,6 +169,11 @@ let mk_noprompt f =
   "-noprompt", Arg.Unit f, " Suppress all prompts"
 ;;
 
+let mk_nopromptcont f =
+  "-nopromptcont", Arg.Unit f,
+  " Suppress prompts for continuation lines of multi-line inputs"
+;;
+
 let mk_nostdlib f =
   "-nostdlib", Arg.Unit f,
   " Do not add default directory to the list of include directories"
@@ -204,10 +213,19 @@ let mk_rectypes f =
   "-rectypes", Arg.Unit f, " Allow arbitrary recursive types"
 ;;
 
+let mk_runtime_variant f =
+  "-runtime-variant", Arg.String f,
+  "<str>  Use the <str> variant of the run-time system"
+;;
+
 let mk_S f =
   "-S", Arg.Unit f, " Keep intermediate assembly file"
 ;;
 
+let mk_stdin f =
+  "-stdin", Arg.Unit f, " Read script from standard input"
+;;
+
 let mk_strict_sequence f =
   "-strict-sequence", Arg.Unit f,
   " Left-hand part of a sequence must have type unit"
@@ -310,6 +328,10 @@ let mk_dlambda f =
   "-dlambda", Arg.Unit f, " (undocumented)"
 ;;
 
+let mk_dclambda f =
+  "-dclambda", Arg.Unit f, " (undocumented)"
+;;
+
 let mk_dinstr f =
   "-dinstr", Arg.Unit f, " (undocumented)"
 ;;
@@ -373,6 +395,7 @@ let mk__ f =
 
 module type Bytecomp_options = sig
   val _a : unit -> unit
+  val _absname : unit -> unit
   val _annot : unit -> unit
   val _c : unit -> unit
   val _cc : string -> unit
@@ -402,6 +425,7 @@ module type Bytecomp_options = sig
   val _pp : string -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
+  val _runtime_variant : string -> unit
   val _strict_sequence : unit -> unit
   val _thread : unit -> unit
   val _vmthread : unit -> unit
@@ -427,6 +451,7 @@ module type Bytecomp_options = sig
 end;;
 
 module type Bytetop_options = sig
+  val _absname : unit -> unit
   val _I : string -> unit
   val _init : string -> unit
   val _labels : unit -> unit
@@ -434,9 +459,11 @@ module type Bytetop_options = sig
   val _noassert : unit -> unit
   val _nolabels : unit -> unit
   val _noprompt : unit -> unit
+  val _nopromptcont : unit -> unit
   val _nostdlib : unit -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
+  val _stdin: unit -> unit
   val _strict_sequence : unit -> unit
   val _unsafe : unit -> unit
   val _version : unit -> unit
@@ -455,6 +482,7 @@ end;;
 
 module type Optcomp_options = sig
   val _a : unit -> unit
+  val _absname : unit -> unit
   val _annot : unit -> unit
   val _c : unit -> unit
   val _cc : string -> unit
@@ -485,9 +513,10 @@ module type Optcomp_options = sig
   val _pp : string -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
+  val _runtime_variant : string -> unit
+  val _S : unit -> unit
   val _strict_sequence : unit -> unit
   val _shared : unit -> unit
-  val _S : unit -> unit
   val _thread : unit -> unit
   val _unsafe : unit -> unit
   val _v : unit -> unit
@@ -503,6 +532,7 @@ module type Optcomp_options = sig
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
+  val _dclambda : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit
@@ -521,6 +551,7 @@ module type Optcomp_options = sig
 end;;
 
 module type Opttop_options = sig
+  val _absname : unit -> unit
   val _compact : unit -> unit
   val _I : string -> unit
   val _init : string -> unit
@@ -530,11 +561,13 @@ module type Opttop_options = sig
   val _noassert : unit -> unit
   val _nolabels : unit -> unit
   val _noprompt : unit -> unit
+  val _nopromptcont : unit -> unit
   val _nostdlib : unit -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
-  val _strict_sequence : unit -> unit
   val _S : unit -> unit
+  val _stdin : unit -> unit
+  val _strict_sequence : unit -> unit
   val _unsafe : unit -> unit
   val _version : unit -> unit
   val _vnum : unit -> unit
@@ -545,6 +578,7 @@ module type Opttop_options = sig
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
+  val _dclambda : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit
@@ -570,6 +604,7 @@ module Make_bytecomp_options (F : Bytecomp_options) =
 struct
   let list = [
     mk_a F._a;
+    mk_absname F._absname;
     mk_annot F._annot;
     mk_c F._c;
     mk_cc F._cc;
@@ -604,6 +639,7 @@ struct
     mk_pp F._pp;
     mk_principal F._principal;
     mk_rectypes F._rectypes;
+    mk_runtime_variant F._runtime_variant;
     mk_strict_sequence F._strict_sequence;
     mk_thread F._thread;
     mk_unsafe F._unsafe;
@@ -633,6 +669,7 @@ end;;
 module Make_bytetop_options (F : Bytetop_options) =
 struct
   let list = [
+    mk_absname F._absname;
     mk_I F._I;
     mk_init F._init;
     mk_labels F._labels;
@@ -640,9 +677,11 @@ struct
     mk_noassert F._noassert;
     mk_nolabels F._nolabels;
     mk_noprompt F._noprompt;
+    mk_nopromptcont F._nopromptcont;
     mk_nostdlib F._nostdlib;
     mk_principal F._principal;
     mk_rectypes F._rectypes;
+    mk_stdin F._stdin;
     mk_strict_sequence F._strict_sequence;
     mk_unsafe F._unsafe;
     mk_version F._version;
@@ -664,6 +703,7 @@ module Make_optcomp_options (F : Optcomp_options) =
 struct
   let list = [
     mk_a F._a;
+    mk_absname F._absname;
     mk_annot F._annot;
     mk_c F._c;
     mk_cc F._cc;
@@ -695,6 +735,7 @@ struct
     mk_pp F._pp;
     mk_principal F._principal;
     mk_rectypes F._rectypes;
+    mk_runtime_variant F._runtime_variant;
     mk_S F._S;
     mk_strict_sequence F._strict_sequence;
     mk_shared F._shared;
@@ -713,11 +754,13 @@ struct
     mk_dparsetree F._dparsetree;
     mk_drawlambda F._drawlambda;
     mk_dlambda F._dlambda;
+    mk_dclambda F._dclambda;
     mk_dcmm F._dcmm;
     mk_dsel F._dsel;
     mk_dcombine F._dcombine;
     mk_dlive F._dlive;
     mk_dspill F._dspill;
+    mk_dsplit F._dsplit;
     mk_dinterf F._dinterf;
     mk_dprefer F._dprefer;
     mk_dalloc F._dalloc;
@@ -732,6 +775,7 @@ end;;
 
 module Make_opttop_options (F : Opttop_options) = struct
   let list = [
+    mk_absname F._absname;
     mk_compact F._compact;
     mk_I F._I;
     mk_init F._init;
@@ -741,10 +785,12 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_noassert F._noassert;
     mk_nolabels F._nolabels;
     mk_noprompt F._noprompt;
+    mk_nopromptcont F._nopromptcont;
     mk_nostdlib F._nostdlib;
     mk_principal F._principal;
     mk_rectypes F._rectypes;
     mk_S F._S;
+    mk_stdin F._stdin;
     mk_strict_sequence F._strict_sequence;
     mk_unsafe F._unsafe;
     mk_version F._version;
@@ -755,11 +801,13 @@ module Make_opttop_options (F : Opttop_options) = struct
 
     mk_dparsetree F._dparsetree;
     mk_drawlambda F._drawlambda;
+    mk_dclambda F._dclambda;
     mk_dcmm F._dcmm;
     mk_dsel F._dsel;
     mk_dcombine F._dcombine;
     mk_dlive F._dlive;
     mk_dspill F._dspill;
+    mk_dsplit F._dsplit;
     mk_dinterf F._dinterf;
     mk_dprefer F._dprefer;
     mk_dalloc F._dalloc;

diff --git a/driver/main_args.mli b/driver/main_args.mli
index 1c4abf50978046fe00cd8f0dd8356c3b6a178bfb..4c9eacca53538b3c942e7a8c6d09c6a8ab939346 100644 (file)
--- a/driver/main_args.mli
+++ b/driver/main_args.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -15,6 +15,7 @@
 module type Bytecomp_options =
   sig
     val _a : unit -> unit
+    val _absname : unit -> unit
     val _annot : unit -> unit
     val _c : unit -> unit
     val _cc : string -> unit
@@ -44,6 +45,7 @@ module type Bytecomp_options =
     val _pp : string -> unit
     val _principal : unit -> unit
     val _rectypes : unit -> unit
+    val _runtime_variant : string -> unit
     val _strict_sequence : unit -> unit
     val _thread : unit -> unit
     val _vmthread : unit -> unit
@@ -70,6 +72,7 @@ module type Bytecomp_options =
 ;;
 
 module type Bytetop_options = sig
+  val _absname : unit -> unit
   val _I : string -> unit
   val _init : string -> unit
   val _labels : unit -> unit
@@ -77,9 +80,11 @@ module type Bytetop_options = sig
   val _noassert : unit -> unit
   val _nolabels : unit -> unit
   val _noprompt : unit -> unit
+  val _nopromptcont : unit -> unit
   val _nostdlib : unit -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
+  val _stdin : unit -> unit
   val _strict_sequence : unit -> unit
   val _unsafe : unit -> unit
   val _version : unit -> unit
@@ -98,6 +103,7 @@ end;;
 
 module type Optcomp_options = sig
   val _a : unit -> unit
+  val _absname : unit -> unit
   val _annot : unit -> unit
   val _c : unit -> unit
   val _cc : string -> unit
@@ -128,9 +134,10 @@ module type Optcomp_options = sig
   val _pp : string -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
+  val _runtime_variant : string -> unit
+  val _S : unit -> unit
   val _strict_sequence : unit -> unit
   val _shared : unit -> unit
-  val _S : unit -> unit
   val _thread : unit -> unit
   val _unsafe : unit -> unit
   val _v : unit -> unit
@@ -146,6 +153,7 @@ module type Optcomp_options = sig
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
+  val _dclambda : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit
@@ -164,6 +172,7 @@ module type Optcomp_options = sig
 end;;
 
 module type Opttop_options = sig
+  val _absname : unit -> unit
   val _compact : unit -> unit
   val _I : string -> unit
   val _init : string -> unit
@@ -173,11 +182,13 @@ module type Opttop_options = sig
   val _noassert : unit -> unit
   val _nolabels : unit -> unit
   val _noprompt : unit -> unit
+  val _nopromptcont : unit -> unit
   val _nostdlib : unit -> unit
   val _principal : unit -> unit
   val _rectypes : unit -> unit
-  val _strict_sequence : unit -> unit
   val _S : unit -> unit
+  val _stdin : unit -> unit
+  val _strict_sequence : unit -> unit
   val _unsafe : unit -> unit
   val _version : unit -> unit
   val _vnum : unit -> unit
@@ -188,6 +199,7 @@ module type Opttop_options = sig
   val _dparsetree : unit -> unit
   val _drawlambda : unit -> unit
   val _dlambda : unit -> unit
+  val _dclambda : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit

diff --git a/driver/ocamlcomp.sh.in b/driver/ocamlcomp.sh.in
index 2aeb2de20b62edd9b5ea1a4c87382267ff5c9586..fc0a8e113faf916b276eada442fe369a62c2c719 100644 (file)
--- a/driver/ocamlcomp.sh.in
+++ b/driver/ocamlcomp.sh.in
@@ -1,5 +1,17 @@
 #!/bin/sh
 
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Jacques Garrigue, Kyoto University RIMS                    #
+#                                                                       #
+#   Copyright 2002 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 topdir=`dirname $0`
 
 exec @compiler@ -nostdlib -I $topdir/stdlib "$@"

diff --git a/driver/optcompile.ml b/driver/optcompile.ml
index 29afc628dca94557b83ba95bf037dfa81548fb8e..1e6ab0ce3f9368e1d5bfcd032f44f1d42ba637e6 100644 (file)
--- a/driver/optcompile.ml
+++ b/driver/optcompile.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -119,12 +119,10 @@ let implementation ppf sourcefile outputprefix =
     if !Clflags.print_types then ignore(
       Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
-      ++ Unused_var.warn ppf
       ++ Typemod.type_implementation sourcefile outputprefix modulename env)
     else begin
       Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
       ++ print_if ppf Clflags.dump_parsetree Printast.implementation
-      ++ Unused_var.warn ppf
       ++ Typemod.type_implementation sourcefile outputprefix modulename env
       ++ Translmod.transl_store_implementation modulename
       +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda

diff --git a/driver/optcompile.mli b/driver/optcompile.mli
index 507d61bbd77b75cac39c952f7b633dd7ce046659..779239a8cc000105405c41df39d2bbc1326a6c96 100644 (file)
--- a/driver/optcompile.mli
+++ b/driver/optcompile.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/driver/opterrors.ml b/driver/opterrors.ml
index 581781997d4c497e193f20e756412b181ba004e6..f931990a4c797bdb26f8a600bedc0fd2d64f5a6e 100644 (file)
--- a/driver/opterrors.ml
+++ b/driver/opterrors.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/driver/opterrors.mli b/driver/opterrors.mli
index d09dc733b6472f363aa6f0a58c8a97a330bdd345..94966741b7311318ff27f23bb79714fa56e35c8c 100644 (file)
--- a/driver/opterrors.mli
+++ b/driver/opterrors.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/driver/optmain.ml b/driver/optmain.ml
index 1c7352c52745c0a89043212db2de764be1d09568..87f4c75f06bb35e0d573ef045d57646b30eaa76e 100644 (file)
--- a/driver/optmain.ml
+++ b/driver/optmain.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -30,6 +30,8 @@ let process_implementation_file ppf name =
   Optcompile.implementation ppf name opref;
   objfiles := (opref ^ ".cmx") :: !objfiles
 
+let cmxa_present = ref false;;
+
 let process_file ppf name =
   if Filename.check_suffix name ".ml"
   || Filename.check_suffix name ".mlt" then
@@ -39,10 +41,12 @@ let process_file ppf name =
     Optcompile.interface ppf name opref;
     if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles
   end
-  else if Filename.check_suffix name ".cmx"
-       || Filename.check_suffix name ".cmxa" then
+  else if Filename.check_suffix name ".cmx" then
+    objfiles := name :: !objfiles
+  else if Filename.check_suffix name ".cmxa" then begin
+    cmxa_present := true;
     objfiles := name :: !objfiles
-  else if Filename.check_suffix name ".cmi" && !make_package then
+  end else if Filename.check_suffix name ".cmi" && !make_package then
     objfiles := name :: !objfiles
   else if Filename.check_suffix name ext_obj
        || Filename.check_suffix name ext_lib then
@@ -56,7 +60,7 @@ let process_file ppf name =
     raise(Arg.Bad("don't know what to do with " ^ name))
 
 let print_version_and_library () =
-  print_string "The Objective Caml native-code compiler, version ";
+  print_string "The OCaml native-code compiler, version ";
   print_string Config.version; print_newline();
   print_string "Standard library directory: ";
   print_string Config.standard_library; print_newline();
@@ -98,6 +102,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let clear r () = r := false
 
   let _a = set make_archive
+  let _absname = set Location.absname
   let _annot = set annotations
   let _c = set compile_only
   let _cc s = c_compiler := Some s
@@ -128,6 +133,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _pp s = preprocessor := Some s
   let _principal = set principal
   let _rectypes = set recursive_types
+  let _runtime_variant s = runtime_variant := s
   let _strict_sequence = set strict_sequence
   let _shared () = shared := true; dlcode := true
   let _S = set keep_asm_file
@@ -146,6 +152,7 @@ module Options = Main_args.Make_optcomp_options (struct
   let _dparsetree = set dump_parsetree
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
+  let _dclambda = set dump_clambda
   let _dcmm = set dump_cmm
   let _dsel = set dump_selection
   let _dcombine = set dump_combine
@@ -175,19 +182,24 @@ let main () =
     then
       fatal "Please specify at most one of -pack, -a, -shared, -c, -output-obj";
     if !make_archive then begin
+      if !cmxa_present then
+        fatal "Option -a cannot be used with .cmxa input files.";
       Optcompile.init_path();
       let target = extract_output !output_name in
       Asmlibrarian.create_archive (List.rev !objfiles) target;
+      Warnings.check_fatal ();
     end
     else if !make_package then begin
       Optcompile.init_path();
       let target = extract_output !output_name in
       Asmpackager.package_files ppf (List.rev !objfiles) target;
+      Warnings.check_fatal ();
     end
     else if !shared then begin
       Optcompile.init_path();
       let target = extract_output !output_name in
       Asmlink.link_shared ppf (List.rev !objfiles) target;
+      Warnings.check_fatal ();
     end
     else if not !compile_only && !objfiles <> [] then begin
       let target =
@@ -206,7 +218,8 @@ let main () =
           default_output !output_name
       in
       Optcompile.init_path();
-      Asmlink.link ppf (List.rev !objfiles) target
+      Asmlink.link ppf (List.rev !objfiles) target;
+      Warnings.check_fatal ();
     end;
     exit 0
   with x ->

diff --git a/driver/optmain.mli b/driver/optmain.mli
index 628d2d398b949579a2fdc41ba6ee4fc8bb632827..701508af28421a596eaffeed982aff320f81646e 100644 (file)
--- a/driver/optmain.mli
+++ b/driver/optmain.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/driver/pparse.ml b/driver/pparse.ml
index 0622ddad9fe18527eef96dba9d8d078806cc6e24..dae174cea23f96a1426a7bf550e0da8031084511 100644 (file)
--- a/driver/pparse.ml
+++ b/driver/pparse.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
@@ -51,15 +51,14 @@ let file ppf inputfile parse_fun ast_magic =
   let ic = open_in_bin inputfile in
   let is_ast_file =
     try
-      let buffer = String.create (String.length ast_magic) in
-      really_input ic buffer 0 (String.length ast_magic);
+      let buffer = Misc.input_bytes ic (String.length ast_magic) in
       if buffer = ast_magic then true
       else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
         raise Outdated_version
       else false
     with
       Outdated_version ->
-        Misc.fatal_error "Ocaml and preprocessor have incompatible versions"
+        Misc.fatal_error "OCaml and preprocessor have incompatible versions"
     | _ -> false
   in
   let ast =

diff --git a/driver/pparse.mli b/driver/pparse.mli
index 0ed0391360d5585f98328fcd282bb28fa6c58e84..96c2594f1e578e424badef7c602f93e67f0d08ef 100644 (file)
--- a/driver/pparse.mli
+++ b/driver/pparse.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/emacs/.cvsignore b/emacs/.cvsignore
deleted file mode 100644 (file)
index ea6381f..0000000
--- a/emacs/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-ocamltags

diff --git a/emacs/.ignore b/emacs/.ignore
new file mode 100644 (file)
index 0000000..ea6381f
--- /dev/null
+++ b/emacs/.ignore
@@ -0,0 +1 @@
+ocamltags

diff --git a/emacs/Makefile b/emacs/Makefile
index 077770c64f910e9729656d7bdf2c411e475969bf..6475be9070e0dca1ff8b5581ea9bf83a95d8d5ca 100644 (file)
--- a/emacs/Makefile
+++ b/emacs/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -41,14 +41,17 @@ COMPILECMD=(progn \
 
 install:
        @if test "$(EMACSDIR)" = ""; then \
+         $(EMACS) --batch --eval 't; see PR#5403'; \
          set xxx `($(EMACS) --batch --eval "(mapcar 'print load-path)") \
-                  2>/dev/null | \
-                  sed -n -e '/\/site-lisp/s/"//gp'`; \
-         if test "$$2" = ""; then \
-           echo "Cannot determine Emacs site-lisp directory"; \
-           exit 2; \
-         fi; \
+                               2>/dev/null | \
+                  sed -n -e 's/^"\(.*\/site-lisp\).*/\1/gp' | \
+                  sort -u`; \
+         if test "$$2" = "" -o "$$3" != ""; then \
+           echo "Cannot determine Emacs site-lisp directory:"; \
+            shift; while test "$$1" != ""; do echo "\t$$1"; shift; done; \
+         else \
          $(MAKE) EMACSDIR="$$2" simple-install; \
+         fi; \
        else \
          $(MAKE) simple-install; \
        fi

diff --git a/emacs/README b/emacs/README
index a1e4782a9cfea194904508074e7a4b4bdb87a729..9c30c8892d847b192fc9870f9ede499c72cb4036 100644 (file)
--- a/emacs/README
+++ b/emacs/README
@@ -1,7 +1,7 @@
-        O'Caml emacs mode, snapshot of $Date: 2008-01-11 17:13:18 +0100 (Fri, 11 Jan 2008) $
+        OCaml emacs mode, snapshot of $Date$
 
 The files in this archive define a caml-mode for emacs, for editing
-Objective Caml and Objective Label programs, as well as an
+OCaml and Objective Label programs, as well as an
 inferior-caml-mode, to run a toplevel.
 
 Caml-mode supports indentation, compilation and error retrieving,
@@ -12,17 +12,20 @@ This package is based on the original caml-mode for caml-light by
 Xavier Leroy, extended with indentation by Ian Zimmerman. For details
 see README.itz, which is the README from Ian Zimmerman's package.
 
-To use it, just put the .el files in your path, and add the following
-three lines in your .emacs.
+To use it, just put the .el files in your emacs load path, and add the
+following lines in your .emacs.
 
-    (setq auto-mode-alist
-          (cons '("\\.ml[iylp]?$" . caml-mode) auto-mode-alist))
-    (autoload 'caml-mode "caml" "Major mode for editing Caml code." t)
-    (autoload 'run-caml "inf-caml" "Run an inferior Caml process." t)
+    (add-to-list 'auto-mode-alist '("\\.ml[iylp]?$" . caml-mode))
+    (autoload 'caml-mode "caml" "Major mode for editing OCaml code." t)
+    (autoload 'run-caml "inf-caml" "Run an inferior OCaml process." t)
+    (autoload 'camldebug "camldebug" "Run ocamldebug on program." t)
+    (add-to-list 'interpreter-mode-alist '("ocamlrun" . caml-mode))
+    (add-to-list 'interpreter-mode-alist '("ocaml" . caml-mode))
 
-I added camldebug.el from the original distribution, since there will
-soon be a debugger for Objective Caml, but I do not know enough about
-it.
+or put the .el files in, eg. "/usr/share/emacs/site-lisp/caml-mode/"
+and add the following line in addtion to the four lines above:
+
+    (add-to-list 'load-path "/usr/share/emacs/site-lisp/caml-mode")
 
 To install the mode itself, edit the Makefile and do
 
@@ -120,7 +123,7 @@ Version 1.07:
 
 Version 1.06:
 ------------
-* new keywords in O'Caml 1.06
+* new keywords in Objective Caml 1.06
 
 * compatibility with GNU Emacs 20
 
@@ -150,7 +153,7 @@ Version 1.03b:
     (setq caml-quote-char "`")
     (setq inferior-caml-program "camllight")
   Literals will be correctly understood and highlighted. However,
-  indentation rules are still Objective Caml's: this just happens to
+  indentation rules are still OCaml's: this just happens to
   work well in most cases, but is only intended for occasional use.
 
 * as many people asked for it, application is now indented. This seems
@@ -164,10 +167,10 @@ Version 1.03b:
 
 Version 1.03:
 ------------
-* support of Objective Caml and Objective Label.
+* support of OCaml and Objective Label.
 
 * an indentation very close to mine, which happens to be the same as
-  Xavier's, since the sources of the Objective Caml compiler do not
+  Xavier's, since the sources of the OCaml compiler do not
   change if you indent them in this mode.
 
 * highlighting.
@@ -175,7 +178,7 @@ Version 1.03:
 Some remarks about the style supported:
 --------------------------------------
 
-Since Objective Caml's syntax is very liberal (more than 100
+Since OCaml's syntax is very liberal (more than 100
 shift-reduce conflicts with yacc), automatic indentation is far from
 easy. Moreover, you expect the indentation to be not purely syntactic,
 but also semantic: reflecting the meaning of your program.

diff --git a/emacs/README.itz b/emacs/README.itz
index 8e1366f4780aeaedcd846d98adcd3ba6132247af..7bcc7aa05dba860994900f2b2114437e05ce822b 100644 (file)
--- a/emacs/README.itz
+++ b/emacs/README.itz
@@ -1,7 +1,7 @@
 DESCRIPTION:
 
-This directory contains files to help editing Caml code, running a
-Caml toplevel, and running the Caml debugger under the Gnu Emacs editor.
+This directory contains files to help editing OCaml code, running a
+OCaml toplevel, and running the OCaml debugger under the Gnu Emacs editor.
 
 AUTHORS:
 
@@ -13,10 +13,10 @@ camldebug.el is derived from FSF code.
 
 CONTENTS:
 
-    caml.el         A major mode for editing Caml code in Gnu Emacs
-    inf-caml.el     To run a Caml toplevel under Emacs, with input and
+    caml.el         A major mode for editing OCaml code in Gnu Emacs
+    inf-caml.el     To run a OCaml toplevel under Emacs, with input and
                     output in an Emacs buffer.
-    camldebug.el    To run the Caml debugger under Emacs.
+    camldebug.el    To run the OCaml debugger under Emacs.
 
 
 NOTE FOR EMACS 18 USERS:
@@ -29,13 +29,13 @@ USAGE:
 Add the following lines to your .emacs file:
 
 (setq auto-mode-alist (cons '("\\.ml[iylp]?" . caml-mode) auto-mode-alist))
-(autoload 'caml-mode "caml" "Major mode for editing Caml code." t)
-(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t)
-(autoload 'camldebug "camldebug" "Run the Caml debugger." t)
+(autoload 'caml-mode "caml" "Major mode for editing OCaml code." t)
+(autoload 'run-caml "inf-caml" "Run an inferior OCaml process." t)
+(autoload 'camldebug "camldebug" "Run the OCaml debugger." t)
 
 The Caml major mode is triggered by visiting a file with extension .ml,
 .mli, .mly. .mll or .mlp, or manually by M-x caml-mode. It gives you the
-correct syntax table for the Caml language. For a brief description of
+correct syntax table for the OCaml language. For a brief description of
 the indentation capabilities, see below under NEWS.
 
 The Caml mode also allows you to run batch Caml compilations from
@@ -44,16 +44,16 @@ sets the point at the beginning of the erroneous program fragment, and
 the mark at the end. Under Emacs 19, the program fragment is
 temporarily highlighted.
 
-M-x run-caml starts a Caml toplevel with input and output in an Emacs
+M-x run-caml starts an OCaml toplevel with input and output in an Emacs
 buffer named *inferior-caml*. This gives you the full power of Emacs
-to edit the input to the Caml toplevel. This mode is based on comint
+to edit the input to the OCaml toplevel. This mode is based on comint
 so you get all the usual comint features, including command history.
 
 After M-x run-caml, typing C-c C-e or M-C-x in a buffer in Caml mode
-sends the current phrase (containing the point) to the Caml toplevel,
+sends the current phrase (containing the point) to the OCaml toplevel,
 and evaluates it.
 
-M-x camldebug FILE starts the Caml debugger camldebug on the executable
+M-x camldebug FILE starts the OCaml debugger camldebug on the executable
 FILE, with input and output in an Emacs buffer named *camldebug-FILE*.
 For a brief description of the commands available in this buffer, see
 NEWS below.

diff --git a/emacs/caml-compat.el b/emacs/caml-compat.el
index 8ba7a99c7ebd6f6d0ed68923393d159441863ecc..da54cd0dc0f6d807fbd7a014c078e4014fdae853 100644 (file)
--- a/emacs/caml-compat.el
+++ b/emacs/caml-compat.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          *)
 ;(*                                                                     *)

diff --git a/emacs/caml-emacs.el b/emacs/caml-emacs.el
index d0a2c86ee0830b01b0ade2baca8cd527b2e8d7aa..06cabf30259928e2a4ca9f09c3210495cad2a2d5 100644 (file)
--- a/emacs/caml-emacs.el
+++ b/emacs/caml-emacs.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*            Didier Remy, projet Cristal, INRIA Rocquencourt          *)
 ;(*                                                                     *)

diff --git a/emacs/caml-font-old.el b/emacs/caml-font-old.el
index 8faa542f050edf7837bb25b2fab9723e6490ed9a..12c318c90ff33bec2ea3d479baca110a55b6c31d 100644 (file)
--- a/emacs/caml-font-old.el
+++ b/emacs/caml-font-old.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*                Jacques Garrigue and Ian T Zimmerman                 *)
 ;(*                                                                     *)
@@ -55,7 +55,7 @@
 ; The same definition is in caml.el:
 ; we don't know in which order they will be loaded.
 (defvar caml-quote-char "'"
-  "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.")
+  "*Quote for character constants. \"'\" for OCaml, \"`\" for Caml-Light.")
 
 (defconst caml-font-lock-keywords
   (list

diff --git a/emacs/caml-font.el b/emacs/caml-font.el
index 956225466d7b6b44f1fa8be7e23061fde7cd6c84..d0eeb5c831479aa4327256c9f60dc621fd881418 100644 (file)
--- a/emacs/caml-font.el
+++ b/emacs/caml-font.el
@@ -1,18 +1,5 @@
 ;; caml-font: font-lock support for OCaml files
-;;
-;; rewrite and clean-up.
-;; Changes:
-;; - fontify strings and comments using syntactic font lock
-;; - define a `font-lock-syntactic-face-function' to fontify ocamldoc comments
-;; - fontify infix operators like mod, land, lsl, etc.
-;; - fontify line number directives
-;; - fontify "failwith" and "invalid_arg" like "raise"
-;; - fontify '\x..' character constants
-;; - use the regexp-opt function to build regexps (more readable)
-;; - use backquote and comma in sexp (more readable)
-;; - drop the `caml-quote-char' variable (I don't use caml-light :))
-;; - stop doing weird things with faces
-
+;; now with perfect parsing of comments and strings
 
 (require 'font-lock)
 
@@ -36,9 +23,6 @@
 
 (defconst caml-font-lock-keywords
   `(
-;character literals
-    ("'\\(.\\|\\\\\\([ntbr\"'\\\\]\\|[0-9]\\{3\\}\\|x[0-9A-Fa-f]\\{2\\}\\)\\)'"
-     . font-lock-string-face)
 ;modules and constructors
    ("`?\\<[A-Z][A-Za-z0-9_']*\\>" . font-lock-function-name-face)
 ;definition
@@ -87,14 +71,299 @@
          ((looking-at "(\\*\\*[^*]")     'caml-font-doccomment-face)
          (t                              'font-lock-comment-face)))))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; In order to correctly fontify an OCaml buffer, it is necessary to
+; lex the buffer to tell what is a comment and what is a string.
+; We do this incrementally in a hook
+; (font-lock-extend-after-change-region-function), which is called
+; whenever the buffer changes.  It sets the syntax-table property
+; on each beginning and end of chars, strings, and comments.
+
+; This mode handles correctly all the strange cases in the following
+; OCaml code.
+;
+; let l' _ = ();;
+; let _' _ = ();;
+; let l' = ();;
+; let b2_' = ();;
+; let a'a' = ();;
+; let f2 _ _ = ();;
+; let f3 _ _ _ = ();;
+; let f' _ _ _ _ _ = ();;
+; let hello = ();;
+;
+; (* ==== easy stuff ==== *)
+;
+; (* a comment *)
+; (* "a string" in a comment *)
+; (* "another string *)" in a comment *)
+; (* not a string '"' in a comment *)
+; "a string";;
+; '"';;              (* not a string *)
+;
+; (* ==== hard stuff ==== *)
+;
+; l'"' not not a string ";;
+; _'"' also not not a string";;
+; f2 0l'"';;            (* not not not a string *)
+; f2 0_'"';;            (* also not not not a string *)
+; f3 0.0l'"' not not not not a string ";;
+; f3 0.0_'"';;          (* not not not not not a string *)
+; f2 0b01_'"';;         (* not not not a string *)
+; f3 0b2_'"'  not not not not a string ";;
+; f3 0b02_'"';;         (* not not not not not a string *)
+; '\'';;   (* a char *)
+; '
+; ';;      (* a char *)
+; '^M
+; ';;      (* also a char [replace ^M with one CR character] *)
+; a'a';;   (* not a char *)
+; type '
+; a' t = X;;   (* also not a char *)
+;
+; (* ==== far-out stuff ==== *)
+;
+;    f'"'" "*) print_endline "hello";;(* \"" ;;
+; (* f'"'" "*) print_endline "hello";;(* \"" ;; *)
+
+
+(defconst caml-font-ident-re
+  "[A-Za-z_\300-\326\330-\366\370-\377][A-Za-z_\300-\326\330-\366\370-\377'0-9]*"
+)
+
+(defconst caml-font-int-re
+  "\\(0[xX][0-9A-Fa-f][0-9A-Fa-f_]*\\|0[oO][0-7][0-7_]*\\|0[bB][01][01_]*\\)[lLn]?"
+)
+
+; decimal integers are folded into the RE for floats to get longest-match
+; without using posix-looking-at
+(defconst caml-font-decimal-re
+  "[0-9][0-9_]*\\([lLn]\\|\\.[0-9_]*\\)?\\([eE][+-]?[0-9][0-9_]*\\)?"
+)
+
+; match any ident or numeral token
+(defconst caml-font-ident-or-num-re
+  (concat caml-font-ident-re "\\|" caml-font-int-re "\\|" caml-font-decimal-re)
+)
+
+; match any char token
+(defconst caml-font-char-re
+  "'\\(\015\012\\|[^\\']\\|\\(\\\\\\([\\'\"ntbr ]\\|[0-9][0-9][0-9]\\|x[0-9A-Fa-f][0-9A-Fa-f]\\)\\)\\)'"
+)
+
+; match a quote followed by a newline
+(defconst caml-font-quote-newline-re
+  "'\\(\015\012\\|[\012\015]\\)"
+)
+
+; match any token or sequence of tokens that cannot contain a
+; quote, double quote, a start of comment, or a newline
+; note: this is only to go faster than one character at a time
+(defconst caml-font-other-re
+  "[^A-Za-z_0-9\012\015\300-\326\330-\366\370-\377'\"(]+"
+)
+
+; match any sequence of non-special characters in a comment
+; note: this is only to go faster than one character at a time
+(defconst caml-font-other-comment-re
+  "[^(*\"'\012\015]+"
+)
+
+; match any sequence of non-special characters in a string
+; note: this is only to go faster than one character at a time
+(defconst caml-font-other-string-re
+  "[^\\\"\012\015]"
+)
+
+; match a newline
+(defconst caml-font-newline-re
+  "\\(\015\012\\|[\012\015]\\)"
+)
+
+; Put the 'caml-font-state property with the given state on the
+; character before pos.  Return nil if it was already there, t if not.
+(defun caml-font-put-state (pos state)
+  (if (equal state (get-text-property (1- pos) 'caml-font-state))
+      nil
+    (put-text-property (1- pos) pos 'caml-font-state state)
+    t)
+)
+
+; Same as looking-at, but erase properties 'caml-font-state and
+; 'syntax-table from the matched range
+(defun caml-font-looking-at (re)
+  (let ((result (looking-at re)))
+    (when result
+      (remove-text-properties (match-beginning 0) (match-end 0)
+                              '(syntax-table nil caml-font-state nil)))
+    result)
+)
+
+; Annotate the buffer starting at point in state (st . depth)
+; Set the 'syntax-table property on beginnings and ends of:
+; - strings
+; - chars
+; - comments
+; Also set the 'caml-font-state property on each LF character that is
+; not preceded by a single quote. The property gives the state of the
+; lexer (nil or t) after reading that character.
+
+; Leave the point at a point where the pre-existing 'caml-font-state
+; property is consistent with the new parse, or at the end of the buffer.
+
+; depth is the depth of nested comments at this point
+;   it must be a non-negative integer
+; st can be:
+;   nil  -- we are in the base state
+;   t    -- we are within a string
+
+(defun caml-font-annotate (st depth)
+  (let ((continue t))
+    (while (and continue (not (eobp)))
+      (cond
+       ((and (equal st nil) (= depth 0)) ; base state, outside comment
+        (cond
+         ((caml-font-looking-at caml-font-ident-or-num-re)
+          (goto-char (match-end 0)))
+         ((caml-font-looking-at caml-font-char-re)
+          (put-text-property (point) (1+ (point))
+                             'syntax-table (string-to-syntax "|"))
+          (put-text-property (1- (match-end 0)) (match-end 0)
+                             'syntax-table (string-to-syntax "|"))
+          (goto-char (match-end 0)))
+         ((caml-font-looking-at caml-font-quote-newline-re)
+          (goto-char (match-end 0)))
+         ((caml-font-looking-at "\"")
+          (put-text-property (point) (1+ (point))
+                             'syntax-table (string-to-syntax "|"))
+          (goto-char (match-end 0))
+          (setq st t))
+         ((caml-font-looking-at "(\\*")
+          (put-text-property (point) (1+ (point))
+                             'syntax-table (string-to-syntax "!"))
+          (goto-char (match-end 0))
+          (setq depth 1))
+         ((looking-at caml-font-newline-re)
+          (goto-char (match-end 0))
+          (setq continue (caml-font-put-state (match-end 0) '(nil . 0))))
+         ((caml-font-looking-at caml-font-other-re)
+          (goto-char (match-end 0)))
+         (t
+          (remove-text-properties (point) (1+ (point))
+                                  '(syntax-table nil caml-font-state nil))
+          (goto-char (1+ (point))))))
+       ((equal st nil)                 ; base state inside comment
+        (cond
+         ((caml-font-looking-at "(\\*")
+          (goto-char (match-end 0))
+          (setq depth (1+ depth)))
+         ((caml-font-looking-at "\\*)")
+          (goto-char (match-end 0))
+          (setq depth (1- depth))
+          (when (= depth 0)
+            (put-text-property (1- (point)) (point)
+                               'syntax-table (string-to-syntax "!"))))
+         ((caml-font-looking-at "\"")
+          (goto-char (match-end 0))
+          (setq st t))
+         ((caml-font-looking-at caml-font-char-re)
+          (goto-char (match-end 0)))
+         ((caml-font-looking-at caml-font-quote-newline-re)
+          (goto-char (match-end 0)))
+         ((caml-font-looking-at "''")
+          (goto-char (match-end 0)))
+         ((looking-at caml-font-newline-re)
+          (goto-char (match-end 0))
+          (setq continue (caml-font-put-state (match-end 0) (cons nil depth))))
+         ((caml-font-looking-at caml-font-other-comment-re)
+          (goto-char (match-end 0)))
+         (t
+          (remove-text-properties (point) (1+ (point))
+                                  '(syntax-table nil caml-font-state nil))
+          (goto-char (1+ (point))))))
+       (t                     ; string state inside or outside a comment
+        (cond
+         ((caml-font-looking-at "\"")
+          (when (= depth 0)
+            (put-text-property (point) (1+ (point))
+                               'syntax-table (string-to-syntax "|")))
+          (goto-char (1+ (point)))
+          (setq st nil))
+         ((caml-font-looking-at "\\\\[\"\\]")
+          (goto-char (match-end 0)))
+         ((looking-at caml-font-newline-re)
+          (goto-char (match-end 0))
+          (setq continue (caml-font-put-state (match-end 0) (cons t depth))))
+         ((caml-font-looking-at caml-font-other-string-re)
+          (goto-char (match-end 0)))
+         (t
+          (remove-text-properties (point) (1+ (point))
+                                  '(syntax-table nil caml-font-state nil))
+          (goto-char (1+ (point)))))))))
+)
+
+; This is the hook function for font-lock-extend-after-change-function
+; It finds the nearest saved state at the left of the changed text,
+; calls caml-font-annotate to set the 'caml-font-state and 'syntax-table
+; properties, then returns the range that was parsed by caml-font-annotate.
+(defun caml-font-extend-after-change (beg end &optional old-len)
+  (save-excursion
+    (save-match-data
+      (let ((caml-font-modified (buffer-modified-p))
+            start-at
+            end-at
+            state)
+        (remove-text-properties beg end '(syntax-table nil caml-font-state nil))
+        (setq start-at
+              (or (and (> beg (point-min))
+                       (get-text-property (1- beg) 'caml-font-state)
+                       beg)
+                  (previous-single-property-change beg 'caml-font-state)
+                  (point-min)))
+        (setq state (or (and (> start-at (point-min))
+                             (get-text-property (1- start-at) 'caml-font-state))
+                        (cons nil 0)))
+        (goto-char start-at)
+        (caml-font-annotate (car state) (cdr state))
+        (setq end-at (point))
+        (restore-buffer-modified-p caml-font-modified)
+        (cons start-at end-at))))
+)
+
+; We don't use the normal caml-mode syntax table because it contains an
+; approximation of strings and comments that interferes with our
+; annotations.
+(defconst caml-font-syntax-table
+  (let ((tbl (make-syntax-table)))
+    (modify-syntax-entry ?' "w" tbl)
+    (modify-syntax-entry ?_ "w" tbl)
+    (modify-syntax-entry ?\" "." tbl)
+    (let ((i 192))
+      (while (< i 256)
+        (or (= i 215) (= i 247) (modify-syntax-entry i "w" tbl))
+        (setq i (1+ i))))
+    tbl))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; font-lock commands are similar for caml-mode and inferior-caml-mode
 (defun caml-font-set-font-lock ()
+  (setq parse-sexp-lookup-properties t)
   (setq font-lock-defaults
-        '(caml-font-lock-keywords
-          nil nil nil nil
-          (font-lock-syntactic-face-function . caml-font-syntactic-face)))
-  (font-lock-mode 1))
+        (list
+         'caml-font-lock-keywords  ; keywords
+         nil  ; keywords-only
+         nil  ; case-fold
+         nil  ; syntax-alist
+         nil  ; syntax-begin
+         (cons 'font-lock-syntax-table caml-font-syntax-table)
+         '(font-lock-extend-after-change-region-function
+           . caml-font-extend-after-change)
+         '(font-lock-syntactic-face-function . caml-font-syntactic-face)
+         ))
+  (caml-font-extend-after-change (point-min) (point-max) 0)
+  (font-lock-mode 1)
+)
 (add-hook 'caml-mode-hook 'caml-font-set-font-lock)
 
 
@@ -104,11 +373,22 @@
     ,@caml-font-lock-keywords))
 
 (defun inferior-caml-set-font-lock ()
+  (setq parse-sexp-lookup-properties t)
   (setq font-lock-defaults
-        '(inferior-caml-font-lock-keywords
-          nil nil nil nil
-          (font-lock-syntactic-face-function . caml-font-syntactic-face)))
-  (font-lock-mode 1))
+        (list
+         'inferior-caml-font-lock-keywords  ; keywords
+         nil  ; keywords-only
+         nil  ; case-fold
+         nil  ; syntax-alist
+         nil  ; syntax-begin
+         (cons 'font-lock-syntax-table caml-font-syntax-table)
+         '(font-lock-extend-after-change-region-function
+           . caml-font-extend-after-change)
+         '(font-lock-syntactic-face-function . caml-font-syntactic-face)
+         ))
+  (caml-font-extend-after-change (point-min) (point-max) 0)
+  (font-lock-mode 1)
+)
 (add-hook 'inferior-caml-mode-hooks 'inferior-caml-set-font-lock)
 
 (provide 'caml-font)

diff --git a/emacs/caml-help.el b/emacs/caml-help.el
index 2adba6752f2dd7db60a911d274afbe9e6d1feb0c..101963294fe864ffe01dd4ec365f90b75a2de23b 100644 (file)
--- a/emacs/caml-help.el
+++ b/emacs/caml-help.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*            Didier Remy, projet Cristal, INRIA Rocquencourt          *)
 ;(*                                                                     *)
@@ -199,7 +199,7 @@
               (insert-file-contents file))
           (message "Module %s not found" module))
         (while (re-search-forward
-                "\\([ \t]*val\\|let\\|external\\|  [|]\\) \\([a-zA-Z_0-9'][a-zA-Z_0-9']*\\)\\|^  *[{]* \\([a-z_][A-Za-z_0-9]*\\) : [^;\n][^;\n]*;"
+                "\\([ \t]*val\\|let\\|exception\\|external\\|  [|]\\) \\([a-zA-Z_0-9'][a-zA-Z_0-9']*\\)\\|^  *[{]* \\([a-z_][A-Za-z_0-9]*\\) : [^;\n][^;\n]*;"
                 (point-max) 'move)
           (pop-to-buffer (current-buffer))
           (setq alist (cons (or (match-string 2) (match-string 3)) alist)))
@@ -606,14 +606,18 @@ current buffer using \\[ocaml-qualified-identifier]."
       )
     (if (stringp entry)
         (let ((here (point))
+              (regex (regexp-quote entry))
               (case-fold-search nil))
           (goto-char (point-min))
           (if (or (re-search-forward
                    (concat "\\(val\\|exception\\|type\\|external\\|[|{;]\\) +"
-                           (regexp-quote entry))
+                           regex)
+                   ;; (concat "\\(val\\|exception\\|external\\) +\\("
+                   ;;         regex "\\|( *" regex " *)\\)")
                    (point-max) t)
                   (re-search-forward
-                   (concat "type [^{]*{[^}]*" (regexp-quote entry) " :")
+                   (concat "type [^{]*{[^}]*" regex " :")
+                   ;; (concat "\\(type\\|[|{;]\\) +" regex)
                    (point-max) t)
                   (progn
                     (if (window-live-p window) (select-window window))
@@ -621,7 +625,7 @@ current buffer using \\[ocaml-qualified-identifier]."
                            entry module))
                   ;; (search-forward entry (point-max) t)
                   )
-              (recenter 1)
+              (ocaml-help-show -1)
             (progn
               (message "Help for entry %s not found in module %s"
                        entry module)
@@ -656,6 +660,7 @@ Prefix arg 4 prompts for Module and identifier instead of guessing values
 from the possition of point in the current buffer.
 "
   (interactive "p")
+  (delete-overlay ocaml-help-ovl)
   (let ((module) (entry) (module-entry))
     (cond
      ((= arg 4)
@@ -669,7 +674,8 @@ from the possition of point in the current buffer.
              (mapcar 'list
                      (ocaml-module-symbols
                       (assoc module (ocaml-module-alist))))))
-        (setq entry (completing-read "Value: " symbols nil t)))
+        (setq entry
+              (completing-read (format "Value: %s." module) symbols nil t)))
       (if (string-equal entry "") (setq entry nil))
       )
      (t
@@ -740,6 +746,22 @@ buffer positions."
 (defvar ocaml-link-map (make-sparse-keymap))
 (define-key ocaml-link-map [mouse-2] 'ocaml-link-goto)
 
+(defvar ocaml-help-ovl (make-overlay 1 1))
+(make-face 'ocaml-help-face)
+(set-face-doc-string 'ocaml-help-face
+                     "face for hilighting expressions and types")
+(if (not (face-differs-from-default-p 'ocaml-help-face))
+    (set-face-background 'ocaml-help-face "#88FF44"))
+(overlay-put ocaml-help-ovl 'face 'ocaml-help-face)
+
+(defun ocaml-help-show (arg)
+  (let ((right (point))
+        (left (progn (forward-word arg) (point))))
+    (goto-char right)
+    (move-overlay ocaml-help-ovl left right (current-buffer))
+    (recenter 1)
+    ))
+
 (defun ocaml-link-goto (click)
   (interactive "e")
   (let* ((pos (caml-event-point-start click))
@@ -761,7 +783,7 @@ buffer positions."
       (if (setq link (assoc link (cdr ocaml-links)))
           (progn
             (goto-char (cadr link))
-            (recenter 1)))
+            (ocaml-help-show 1)))
       (if (window-live-p window) (select-window window))
       )))
 

diff --git a/emacs/caml-hilit.el b/emacs/caml-hilit.el
index 697e58173d8a03da1748e1e087679cf8afe53479..25376eb2a4e98c8124fc62e5b1f9ffb86356d035 100644 (file)
--- a/emacs/caml-hilit.el
+++ b/emacs/caml-hilit.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*                Jacques Garrigue and Ian T Zimmerman                 *)
 ;(*                                                                     *)
@@ -16,7 +16,7 @@
 
 ; defined also in caml.el
 (defvar caml-quote-char "'"
-  "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.")
+  "*Quote for character constants. \"'\" for OCaml, \"`\" for Caml-Light.")
 
 (defconst caml-mode-patterns
   (list
@@ -53,7 +53,7 @@
           "\\|\|\\|->\\|&\\|#")
          nil 'keyword)
    '(";" nil struct))
-  "Hilit19 patterns used for Caml mode")
+  "Hilit19 patterns used for OCaml mode")
 
 (hilit-set-mode-patterns 'caml-mode caml-mode-patterns)
 (hilit-set-mode-patterns

diff --git a/emacs/caml-types.el b/emacs/caml-types.el
index 3c7433a813e10b12aa0faf50850407e91db9ea18..e42a0fc46de51534e03a41e6c1da7dcd4750b7c3 100644 (file)
--- a/emacs/caml-types.el
+++ b/emacs/caml-types.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 ;(*                                                                     *)
@@ -38,7 +38,7 @@ Their format is:
   <SP> is a space character (ASCII 0x20)
   <LF> is a line-feed character (ASCII 0x0A)
   num is a sequence of decimal digits
-  filename is a string with the lexical conventions of O'Caml
+  filename is a string with the lexical conventions of OCaml
   open-paren is an open parenthesis (ASCII 0x28)
   close-paren is a closed parenthesis (ASCII 0x29)
   data is any sequence of characters where <LF> is always followed by
@@ -411,8 +411,7 @@ See `caml-types-location-re' for annotation file format.
         (unless (caml-types-not-in-file l-file r-file target-file)
           (setq annotation ())
           (while (next-annotation)
-            (cond ((looking-at
-                    "^\\([a-z]+\\)(\n  \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
+            (cond ((looking-at "^\\([a-z]+\\)(\n  \\(\\(.*\n  \\)*.*\\)\n)")
                    (let ((kind (caml-types-hcons (match-string 1) table))
                          (info (caml-types-hcons (match-string 2) table)))
                      (setq annotation (cons (cons kind info) annotation))))))

diff --git a/emacs/caml-xemacs.el b/emacs/caml-xemacs.el
index 45d670c7abd59151ad34042c338c7b86a3787243..79321e0057219063ba3a74e49638a658ee3837bd 100644 (file)
--- a/emacs/caml-xemacs.el
+++ b/emacs/caml-xemacs.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*            Didier Remy, projet Cristal, INRIA Rocquencourt          *)
 ;(*                                                                     *)

diff --git a/emacs/caml.el b/emacs/caml.el
index 2e37bff527b67e83971acbbb552de64d800a75ee..d1127f789c193f4957a5d188f9f94400ee0fe282 100644 (file)
--- a/emacs/caml.el
+++ b/emacs/caml.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*                Jacques Garrigue and Ian T Zimmerman                 *)
 ;(*                                                                     *)
@@ -12,19 +12,19 @@
 
 ;(* $Id$ *)
 
-;;; caml.el --- O'Caml code editing commands for Emacs
+;;; caml.el --- OCaml code editing commands for Emacs
 
 ;; Xavier Leroy, july 1993.
 
 ;;indentation code is Copyright (C) 1996 by Ian T Zimmerman <itz@rahul.net>
 ;;copying: covered by the current FSF General Public License.
 
-;; indentation code adapted for Objective Caml by Jacques Garrigue,
+;; indentation code adapted for OCaml by Jacques Garrigue,
 ;; july 1997. <garrigue@kurims.kyoto-u.ac.jp>
 
 ;;user customizable variables
 (defvar caml-quote-char "'"
-  "*Quote for character constants. \"'\" for Objective Caml, \"`\" for Caml-Light.")
+  "*Quote for character constants. \"'\" for OCaml, \"`\" for Caml-Light.")
 
 (defvar caml-imenu-enable nil
   "*Enable Imenu support.")
@@ -484,7 +484,7 @@ have caml-electric-indent on, which see.")
   "Hook for caml-mode")
 
 (defun caml-mode ()
-  "Major mode for editing Caml code.
+  "Major mode for editing OCaml code.
 
 \\{caml-mode-map}"
 
@@ -588,7 +588,7 @@ have caml-electric-indent on, which see.")
 ;;; subshell support
 
 (defun caml-eval-region (start end)
-  "Send the current region to the inferior Caml process."
+  "Send the current region to the inferior OCaml process."
   (interactive"r")
   (require 'inf-caml)
   (inferior-caml-eval-region start end))
@@ -596,7 +596,7 @@ have caml-electric-indent on, which see.")
 ;; old version ---to be deleted later
 ;
 ; (defun caml-eval-phrase ()
-;   "Send the current Caml phrase to the inferior Caml process."
+;   "Send the current OCaml phrase to the inferior Caml process."
 ;   (interactive)
 ;   (save-excursion
 ;     (let ((bounds (caml-mark-phrase)))
@@ -825,7 +825,7 @@ from an error message produced by camlc.")
 ;that way we get our effect even when we do \C-x` in compilation buffer
 
 (defadvice next-error (after caml-next-error activate)
- "Reads the extra positional information provided by the Caml compiler.
+ "Reads the extra positional information provided by the OCaml compiler.
 
 Puts the point and the mark exactly around the erroneous program
 fragment. The erroneous fragment is also temporarily highlighted if
@@ -903,7 +903,7 @@ whole string."
 ;; itz Thu Sep 24 19:02:42 PDT 1998 this is to have some level of
 ;; comfort when sending phrases to the toplevel and getting errors.
 (defun caml-goto-phrase-error ()
-  "Find the error location in current Caml phrase."
+  "Find the error location in current OCaml phrase."
   (interactive)
   (require 'inf-caml)
   (let ((bounds (save-excursion (caml-mark-phrase))))
@@ -984,7 +984,7 @@ to the end.
     beg))
 
 (defun caml-mark-phrase (&optional min-pos max-pos)
-  "Put mark at end of this Caml phrase, point at beginning.
+  "Put mark at end of this OCaml phrase, point at beginning.
 "
   (interactive)
   (let* ((beg (caml-find-phrase min-pos max-pos)) (end (point)))
@@ -1756,7 +1756,7 @@ by |, insert one."
       (goto-char (match-end 0))))
 
 ;; to mark phrases, so that repeated calls will take several of them
-;; knows little about Ocaml appart literals and comments, so it should work
+;; knows little about OCaml except literals and comments, so it should work
 ;; with other dialects as long as ;; marks the end of phrase.
 
 (defun caml-indent-phrase (arg)
@@ -1912,7 +1912,7 @@ with prefix arg, indent that many phrases starting with the current phrase."
     (beginning-of-line 1)
     (backward-char 4)))
 
-(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t)
+(autoload 'run-caml "inf-caml" "Run an inferior OCaml process." t)
 
 (autoload 'caml-types-show-type "caml-types"
   "Show the type of expression or pattern at point." t)

diff --git a/emacs/camldebug.el b/emacs/camldebug.el
index 57a98701b5374a57d46c602cb349b6aace5834d9..0fd353aef0ac01029464021d81c16445324d72fa 100644 (file)
--- a/emacs/camldebug.el
+++ b/emacs/camldebug.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*                Jacques Garrigue and Ian T Zimmerman                 *)
 ;(*                                                                     *)
@@ -89,7 +89,7 @@
 
 (define-derived-mode camldebug-mode comint-mode "Inferior CDB"
 
-  "Major mode for interacting with an inferior Camldebug process.
+  "Major mode for interacting with an inferior ocamldebug process.
 
 The following commands are available:
 

diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el
index f3e4c48d1b577e7996e8e63074f5f0ced8caf7b9..5b864efcb06e9d9172695e9fe6ef3d30f8f250c3 100644 (file)
--- a/emacs/inf-caml.el
+++ b/emacs/inf-caml.el
@@ -1,6 +1,6 @@
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*                   Xavier Leroy and Jacques Garrigue                 *)
 ;(*                                                                     *)
@@ -12,7 +12,7 @@
 
 ;(* $Id$ *)
 
-;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer
+;;; inf-caml.el --- run the OCaml toplevel in an Emacs buffer
 
 ;; Xavier Leroy, july 1993.
 
@@ -37,14 +37,14 @@
   (setq inferior-caml-mode-map
         (copy-keymap comint-mode-map)))
 
-;; Augment Caml mode, so you can process Caml code in the source files.
+;; Augment Caml mode, so you can process OCaml code in the source files.
 
 (defvar inferior-caml-program "ocaml"
-  "*Program name for invoking an inferior Caml from Emacs.")
+  "*Program name for invoking an inferior OCaml from Emacs.")
 
 (defun inferior-caml-mode ()
-  "Major mode for interacting with an inferior Caml process.
-Runs a Caml toplevel as a subprocess of Emacs, with I/O through an
+  "Major mode for interacting with an inferior OCaml process.
+Runs an OCaml toplevel as a subprocess of Emacs, with I/O through an
 Emacs buffer. A history of input phrases is maintained. Phrases can
 be sent from another buffer in Caml mode.
 
@@ -95,7 +95,7 @@ be sent from another buffer in Caml mode.
 
 (defun inferior-caml-mode-output-hook ()
   (set-variable 'comint-output-filter-functions
-        (list (function inferior-caml-signal-output)) 
+        (list (function inferior-caml-signal-output))
         t))
 (add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-output-hook)
 
@@ -106,7 +106,7 @@ be sent from another buffer in Caml mode.
     (if (not cmd)
         (if (comint-check-proc inferior-caml-buffer-name)
             (setq cmd inferior-caml-program)
-          (setq cmd (read-from-minibuffer "Caml toplevel to run: "
+          (setq cmd (read-from-minibuffer "OCaml toplevel to run: "
                                           inferior-caml-program))))
     (setq inferior-caml-program cmd)
     (let ((cmdlist (inferior-caml-args-to-list cmd))
@@ -124,11 +124,11 @@ be sent from another buffer in Caml mode.
 ;;  caml-run-process-when-needed
 
 (defun run-caml (&optional cmd)
-  "Run an inferior Caml process.
+  "Run an inferior OCaml process.
 Input and output via buffer `*inferior-caml*'."
   (interactive
    (list (if (not (comint-check-proc inferior-caml-buffer-name))
-             (read-from-minibuffer "Caml toplevel to run: "
+             (read-from-minibuffer "OCaml toplevel to run: "
                                    inferior-caml-program))))
   (caml-run-process-if-needed cmd)
   (switch-to-buffer-other-window inferior-caml-buffer-name))
@@ -174,7 +174,7 @@ Input and output via buffer `*inferior-caml*'."
 ;; patched by Didier to move cursor after evaluation
 
 (defun inferior-caml-eval-region (start end)
-  "Send the current region to the inferior Caml process."
+  "Send the current region to the inferior OCaml process."
   (interactive "r")
   (save-excursion (caml-run-process-if-needed))
   (save-excursion

diff --git a/emacs/ocamltags.in b/emacs/ocamltags.in
index aa3f8df1d2651739ef19f9bbbac6b026c58c8e0f..2a6aadbfb7522a59110ddcaeaf98971f62aa51dc 100644 (file)
--- a/emacs/ocamltags.in
+++ b/emacs/ocamltags.in
@@ -2,7 +2,7 @@
 
 ;(***********************************************************************)
 ;(*                                                                     *)
-;(*                           Objective Caml                            *)
+;(*                                OCaml                                *)
 ;(*                                                                     *)
 ;(*                Jacques Garrigue and Ian T Zimmerman                 *)
 ;(*                                                                     *)

diff --git a/experimental/doligez/checkheaders b/experimental/doligez/checkheaders
new file mode 100755 (executable)
index 0000000..044080f
--- /dev/null
+++ b/experimental/doligez/checkheaders
@@ -0,0 +1,159 @@
+#!/bin/sh
+
+#######################################################################
+#                                                                     #
+#                                OCaml                                #
+#                                                                     #
+#          Damien Doligez, projet Gallium, INRIA Rocquencourt         #
+#                                                                     #
+#  Copyright 2011 Institut National de Recherche en Informatique et   #
+#  en Automatique.  All rights reserved.  This file is distributed    #
+#  under the terms of the Q Public License version 1.0.               #
+#                                                                     #
+#######################################################################
+
+(
+case $# in
+  0) find . -type f -print;;
+  *) echo $1;;
+esac
+) | \
+while read f; do 
+awk -f - "$f" <<\EOF
+
+function checkline (x) {
+  return ( $0 ~ ("^.{0,4}" x) );
+}
+
+function hrule () {
+  return (checkline("[*#]{69}"));
+}
+
+function blank () {
+  return (checkline(" {69}"));
+}
+
+function ocaml () {
+  return (checkline(" {32}OCaml {32}") \
+       || checkline(" {35}OCaml {32}") \
+       || checkline("                 MLTk, Tcl/Tk interface of OCaml                     ") \
+       || checkline("                         OCaml LablTk library                          ") \
+       || checkline("                             ocamlbuild                              ") \
+       || checkline("                             OCamldoc                                ") \
+  );
+}
+
+function any () {
+  return (checkline(".{69}"));
+}
+
+function copy1 () {
+  return (checkline("  Copyright +[-0-9]+ +Institut +National +de +Recherche +en +Informatique +et   "));
+}
+
+function copy2 () {
+  return (checkline("  en Automatique"));
+}
+
+function err () {
+  printf ("File \"%s\", line %d:\n", FILENAME, FNR);
+  printf ("  Error: line %d of header is wrong.\n", FNR + offset);
+  print $0;
+}
+
+function add_ignore_re (x) {
+    ignore_re[++ignore_re_index] = x;
+}
+
+function add_exception (x) {
+    exception[++exception_index] = x;
+}
+
+FNR == 1 {
+  offset = 0;
+  add_ignore_re("/\\.svn/");
+  add_ignore_re("/\\.depend(\\.nt)?$");
+  add_ignore_re("/\\.ignore$");
+  add_ignore_re("\\.gif$");
+  add_ignore_re("/[A-Z]*$");
+  add_ignore_re("/README\\.[^/]*$");
+  add_ignore_re("/Changes$");
+  add_ignore_re("\\.mlpack$");
+  add_ignore_re("\\.mllib$");
+  add_ignore_re("\\.mltop$");
+  add_ignore_re("\\.clib$");
+  add_ignore_re("\\.odocl$");
+  add_ignore_re("\\.itarget$");
+  add_ignore_re("^\\./boot/");
+  add_ignore_re("^\\./camlp4/test/");
+  add_ignore_re("^\\./camlp4/unmaintained/");
+  add_ignore_re("^\\./config/gnu/");
+  add_ignore_re("^\\./experimental/");
+  add_ignore_re("^\\./ocamlbuild/examples/");
+  add_ignore_re("^\\./ocamlbuild/test/");
+  add_ignore_re("^\\./otherlibs/labltk/builtin/");
+  add_ignore_re("^\\./otherlibs/labltk/examples_");
+  add_ignore_re("^\\./testsuite/");
+  for (i in ignore_re){
+      if (FILENAME ~ ignore_re[i]) { nextfile; }
+  }
+  add_exception("./asmrun/m68k.S");                     # obsolete
+  add_exception("./build/camlp4-bootstrap-recipe.txt");
+  add_exception("./build/new-build-system");
+  add_exception("./ocamlbuild/ChangeLog");
+  add_exception("./ocamlbuild/manual/myocamlbuild.ml"); # TeX input file ?
+  add_exception("./ocamlbuild/manual/trace.out");       # TeX input file
+  add_exception("./ocamldoc/Changes.txt");
+  add_exception("./ocamldoc/ocamldoc.sty");             # public domain
+  add_exception("./otherlibs/labltk/browser/help.txt");
+  add_exception("./otherlibs/labltk/camltk/modules");   # generated
+  add_exception("./otherlibs/labltk/labltk/modules");   # generated
+  add_exception("./tools/objinfo_helper.c");            # non-INRIA
+  add_exception("./tools/magic");                       # public domain ?
+  add_exception("./Upgrading");
+  add_exception("./win32caml/inriares.h");              # generated
+  add_exception("./win32caml/ocaml.rc");                # generated
+  add_exception("./win32caml/resource.h");              # generated
+  for (i in exception){
+      if (FILENAME == exception[i]) { nextfile; }
+  }
+}
+
+# 1 [!hrule]     #!
+# 2 [!hrule]     empty
+# 3 hrule
+# 4 [blank]
+# 5 ocaml        title
+# 6 blank
+# 7 any          author
+# 8 [!blank]     author
+# 9 [!blank]     author
+#10 blank
+#11 copy1        copyright
+#12 copy2        copyright
+#13 any          copyright
+#14 [!blank]     copyright
+#15 [!blank]     copyright
+#16 blank
+#17 hrule
+
+FNR + offset == 1 && hrule() { ++offset; }
+FNR + offset == 2 && hrule() { ++offset; }
+FNR + offset == 3 && ! hrule() { err(); nextfile; }
+FNR + offset == 4 && ! blank() { ++offset; }
+FNR + offset == 5 && ! ocaml() { err(); nextfile; }
+FNR + offset == 6 && ! blank() { err(); nextfile; }
+FNR + offset == 7 && ! any() { err(); nextfile; }
+FNR + offset == 8 && blank() { ++offset; }
+FNR + offset == 9 && blank() { ++offset; }
+FNR + offset ==10 && ! blank() { err(); nextfile; }
+FNR + offset ==11 && ! copy1() { err(); nextfile; }
+FNR + offset ==12 && ! copy2() { err(); nextfile; }
+FNR + offset ==13 && ! any() { err(); nextfile; }
+FNR + offset ==14 && blank() { ++offset; }
+FNR + offset ==15 && blank() { ++offset; }
+FNR + offset ==16 && ! blank() { err(); nextfile; }
+FNR + offset ==17 && ! hrule() { err(); nextfile; }
+
+EOF
+done

diff --git a/experimental/garrigue/.cvsignore b/experimental/garrigue/.cvsignore
new file mode 100644 (file)
index 0000000..4c57147
--- /dev/null
+++ b/experimental/garrigue/.cvsignore
@@ -0,0 +1 @@
+*.out *.out2
\ No newline at end of file

diff --git a/experimental/garrigue/caml_set_oid.diffs b/experimental/garrigue/caml_set_oid.diffs
new file mode 100644 (file)
index 0000000..aaaa160
--- /dev/null
+++ b/experimental/garrigue/caml_set_oid.diffs
@@ -0,0 +1,141 @@
+Index: byterun/intern.c
+===================================================================
+--- byterun/intern.c   (revision 11929)
++++ byterun/intern.c   (working copy)
+@@ -27,6 +27,7 @@
+ #include "memory.h"
+ #include "mlvalues.h"
+ #include "misc.h"
++#include "obj.h"
+ #include "reverse.h"
+ 
+ static unsigned char * intern_src;
+@@ -139,6 +140,14 @@
+         dest = (value *) (intern_dest + 1);
+         *intern_dest = Make_header(size, tag, intern_color);
+         intern_dest += 1 + size;
++        /* For objects, we need to freshen the oid */
++        if (tag == Object_tag) {
++          intern_rec(dest++);
++          intern_rec(dest++);
++          caml_set_oid((value)(dest-2));
++          size -= 2;
++          if (size == 0) return;
++        }
+         for(/*nothing*/; size > 1; size--, dest++)
+           intern_rec(dest);
+         goto tailcall;
+Index: byterun/obj.c
+===================================================================
+--- byterun/obj.c      (revision 11929)
++++ byterun/obj.c      (working copy)
+@@ -25,6 +25,7 @@
+ #include "minor_gc.h"
+ #include "misc.h"
+ #include "mlvalues.h"
++#include "obj.h"
+ #include "prims.h"
+ 
+ CAMLprim value caml_static_alloc(value size)
+@@ -212,6 +213,16 @@
+   return (tag == Field(meths,li) ? Field (meths, li-1) : 0);
+ }
+ 
++/* Generate ids on the C side, to avoid races */
++
++CAMLprim value caml_set_oid (value obj)
++{
++  static value last_oid = 1;
++  Field(obj,1) = last_oid;
++  last_oid += 2;
++  return obj;
++}
++
+ /* these two functions might be useful to an hypothetical JIT */
+ 
+ #ifdef CAML_JIT
+Index: byterun/obj.h
+===================================================================
+--- byterun/obj.h      (revision 0)
++++ byterun/obj.h      (revision 0)
+@@ -0,0 +1,28 @@
++/***********************************************************************/
++/*                                                                     */
++/*                                OCaml                                */
++/*                                                                     */
++/*        Jacques Garrigue, projet Cristal, INRIA Rocquencourt         */
++/*                                                                     */
++/*  Copyright 1996 Institut National de Recherche en Informatique et   */
++/*  en Automatique.  All rights reserved.  This file is distributed    */
++/*  under the terms of the GNU Library General Public License, with    */
++/*  the special exception on linking described in file ../LICENSE.     */
++/*                                                                     */
++/***********************************************************************/
++
++/* $Id$ */
++
++/* Primitives for the Obj and CamlinternalOO modules */
++
++#ifndef CAML_OBJ_H
++#define CAML_OBJ_H
++
++#include "misc.h"
++#include "mlvalues.h"
++
++/* Set the OID of an object to a fresh value */
++/* returns the same object as result */
++value caml_set_oid (value obj);
++
++#endif /* CAML_OBJ_H */
+Index: stdlib/camlinternalOO.ml
+===================================================================
+--- stdlib/camlinternalOO.ml   (revision 11929)
++++ stdlib/camlinternalOO.ml   (working copy)
+@@ -15,23 +15,15 @@
+ 
+ open Obj
+ 
+-(**** Object representation ****)
++(**** OID handling ****)
+ 
+-let last_id = ref 0
+-let new_id () =
+-  let id = !last_id in incr last_id; id
++external set_oid : t -> t = "caml_set_oid" "noalloc"
+ 
+-let set_id o id =
+-  let id0 = !id in
+-  Array.unsafe_set (Obj.magic o : int array) 1 id0;
+-  id := id0 + 1
+-
+ (**** Object copy ****)
+ 
+ let copy o =
+-  let o = (Obj.obj (Obj.dup (Obj.repr o))) in
+-  set_id o last_id;
+-  o
++  let o =  Obj.dup (Obj.repr o) in
++  Obj.obj (set_oid o)
+ 
+ (**** Compression options ****)
+ (* Parameters *)
+@@ -355,8 +347,7 @@
+   let obj = Obj.new_block Obj.object_tag table.size in
+   (* XXX Appel de [caml_modify] *)
+   Obj.set_field obj 0 (Obj.repr table.methods);
+-  set_id obj last_id;
+-  (Obj.obj obj)
++  Obj.obj (set_oid obj)
+ 
+ let create_object_opt obj_0 table =
+   if (Obj.magic obj_0 : bool) then obj_0 else begin
+@@ -364,8 +355,7 @@
+     let obj = Obj.new_block Obj.object_tag table.size in
+     (* XXX Appel de [caml_modify] *)
+     Obj.set_field obj 0 (Obj.repr table.methods);
+-    set_id obj last_id;
+-    (Obj.obj obj)
++    Obj.obj (set_oid obj)
+   end
+ 
+ let rec iter_f obj =

diff --git a/experimental/garrigue/coerce.diffs b/experimental/garrigue/coerce.diffs
new file mode 100644 (file)
index 0000000..e90e1fc
--- /dev/null
+++ b/experimental/garrigue/coerce.diffs
@@ -0,0 +1,93 @@
+Index: typing/ctype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
+retrieving revision 1.201
+diff -u -r1.201 ctype.ml
+--- typing/ctype.ml    5 Apr 2006 02:28:13 -0000       1.201
++++ typing/ctype.ml    17 May 2006 23:48:22 -0000
+@@ -490,6 +490,31 @@
+     unmark_class_signature sign;
+     Some reason
+ 
++(* Variant for checking principality *)
++
++let rec free_nodes_rec ty =
++  let ty = repr ty in
++  if ty.level >= lowest_level then begin
++    if ty.level <= !current_level then raise Exit;
++    ty.level <- pivot_level - ty.level;
++    begin match ty.desc with
++      Tvar ->
++        raise Exit
++    | Tobject (ty, _) ->
++        free_nodes_rec ty
++    | Tfield (_, _, ty1, ty2) ->
++        free_nodes_rec ty1; free_nodes_rec ty2
++    | Tvariant row ->
++        let row = row_repr row in
++        iter_row free_nodes_rec {row with row_bound = []};
++        if not (static_row row) then free_nodes_rec row.row_more
++    | _    ->
++        iter_type_expr free_nodes_rec ty
++    end;
++  end
++
++let has_free_nodes ty =
++  try free_nodes_rec ty; false with Exit -> true
+ 
+                             (**********************)
+                             (*  Type duplication  *)
+Index: typing/ctype.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
+retrieving revision 1.54
+diff -u -r1.54 ctype.mli
+--- typing/ctype.mli   5 Apr 2006 02:28:13 -0000       1.54
++++ typing/ctype.mli   17 May 2006 23:48:22 -0000
+@@ -228,6 +228,9 @@
+ val closed_class:
+         type_expr list -> class_signature -> closed_class_failure option
+         (* Check whether all type variables are bound *)
++val has_free_nodes: type_expr -> bool
++        (* Check whether there are free type variables, or nodes with
++           level lower or equal to !current_level *)
+ 
+ val unalias: type_expr -> type_expr
+ val signature_of_class_type: class_type -> class_signature
+Index: typing/typecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
+retrieving revision 1.181
+diff -u -r1.181 typecore.ml
+--- typing/typecore.ml 16 Apr 2006 23:28:22 -0000      1.181
++++ typing/typecore.ml 17 May 2006 23:48:22 -0000
+@@ -1183,12 +1183,29 @@
+             let (ty', force) =
+               Typetexp.transl_simple_type_delayed env sty'
+             in
++            if !Clflags.principal then begin_def ();
+             let arg = type_exp env sarg in
++            let has_fv =
++              if !Clflags.principal then begin
++                end_def ();
++                let b = has_free_nodes arg.exp_type in
++                Ctype.unify env arg.exp_type (newvar ());
++                b
++              end else
++                free_variables arg.exp_type <> []
++            in
+             begin match arg.exp_desc, !self_coercion, (repr ty').desc with
+               Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
+               Tconstr(path',_,_) when Path.same path path' ->
+                 r := sexp.pexp_loc :: !r;
+                 force ()
++            | _ when not has_fv ->
++                begin try
++                  let force' = subtype env arg.exp_type ty' in
++                  force (); force' ()
++                with Subtype (tr1, tr2) ->
++                  raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
++                end
+             | _ ->
+                 let ty, b = enlarge_type env ty' in
+                 force ();

diff --git a/experimental/garrigue/dirs_multimatch b/experimental/garrigue/dirs_multimatch
new file mode 100644 (file)
index 0000000..b449514
--- /dev/null
+++ b/experimental/garrigue/dirs_multimatch
@@ -0,0 +1 @@
+parsing typing bytecomp driver toplevel
\ No newline at end of file

diff --git a/experimental/garrigue/dirs_poly b/experimental/garrigue/dirs_poly
new file mode 100644 (file)
index 0000000..3aec606
--- /dev/null
+++ b/experimental/garrigue/dirs_poly
@@ -0,0 +1 @@
+bytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml

diff --git a/experimental/garrigue/fixedtypes.ml b/experimental/garrigue/fixedtypes.ml
new file mode 100644 (file)
index 0000000..a7d7ca4
--- /dev/null
+++ b/experimental/garrigue/fixedtypes.ml
@@ -0,0 +1,77 @@
+(* cvs update -r fixedtypes parsing typing *)
+
+(* recursive types *)
+class c = object (self) method m = 1 method s = self end
+module type S = sig type t = private #c end;;
+
+module M : S = struct type t = c end
+module type S' = S with type t = c;;
+
+class d = object inherit c method n = 2 end
+module type S2 = S with type t = private #d;;
+module M2 : S = struct type t = d end;;
+module M3 : S = struct type t = private #d end;;
+
+module T1 = struct
+  type ('a,'b) a = [`A of 'a | `B of 'b]
+  type ('a,'b) b = [`Z | ('a,'b) a]
+end
+module type T2 = sig
+  type a and b
+  val evala : a -> int
+  val evalb : b -> int
+end
+module type T3 = sig
+  type a0 = private [> (a0,b0) T1.a]
+  and b0 = private [> (a0,b0) T1.b]
+end
+module type T4 = sig
+  include T3
+  include T2 with type a = a0 and type b = b0
+end
+module F(X:T4) = struct
+  type a = X.a and b = X.b
+  let a = X.evala (`B `Z)
+  let b = X.evalb (`A(`B `Z))
+  let a2b (x : a) : b = `A x
+  let b2a (x : b) : a = `B x
+end
+module M4 = struct
+  type a = [`A of a | `B of b | `ZA]
+  and b = [`A of a | `B of b | `Z]
+  type a0 = a
+  type b0 = b
+  let rec eval0 = function
+      `A a -> evala a
+    | `B b -> evalb b
+  and evala : a -> int = function
+      #T1.a as x -> 1 + eval0 x
+    | `ZA -> 3
+  and evalb : b -> int = function
+      #T1.a as x -> 1 + eval0 x
+    | `Z -> 7
+end
+module M5 = F(M4)
+
+module M6 : sig
+  class ci : int ->
+    object
+      val x : int
+      method x : int
+      method move : int -> unit
+    end      
+  type c = private #ci
+  val create : int -> c
+end = struct
+  class ci x = object
+    val mutable x : int = x
+    method x = x
+    method move d = x <- x+d
+  end
+  type c = ci
+  let create = new ci
+end
+let f (x : M6.c) = x#move 3; x#x;;
+
+module M : sig type t = private [> `A of bool] end =
+  struct type t = [`A of int] end

diff --git a/experimental/garrigue/gadt-escape-check.diffs b/experimental/garrigue/gadt-escape-check.diffs
new file mode 100644 (file)
index 0000000..3e4a44e
--- /dev/null
+++ b/experimental/garrigue/gadt-escape-check.diffs
@@ -0,0 +1,519 @@
+Index: typing/env.ml
+===================================================================
+--- typing/env.ml      (revision 11214)
++++ typing/env.ml      (working copy)
+@@ -20,6 +20,7 @@
+ open Longident
+ open Path
+ open Types
++open Btype
+ 
+ 
+ type error =
+@@ -56,7 +57,7 @@
+   cltypes: (Path.t * cltype_declaration) Ident.tbl;
+   summary: summary;
+   local_constraints: bool;
+-  level_map: (int * int) list;
++  gadt_instances: (int * TypeSet.t ref) list;
+ }
+ 
+ and module_components = module_components_repr Lazy.t
+@@ -96,7 +97,7 @@
+   modules = Ident.empty; modtypes = Ident.empty;
+   components = Ident.empty; classes = Ident.empty;
+   cltypes = Ident.empty; 
+-  summary = Env_empty; local_constraints = false; level_map = [] }
++  summary = Env_empty; local_constraints = false; gadt_instances = [] }
+ 
+ let diff_keys is_local tbl1 tbl2 =
+   let keys2 = Ident.keys tbl2 in
+@@ -286,13 +287,14 @@
+   (* the level is changed when updating newtype definitions *)
+   if !Clflags.principal then begin
+     match level, decl.type_newtype_level with
+-      Some level, Some def_level when level < def_level -> raise Not_found
++      Some level, Some (_, exp_level) when level < exp_level -> raise Not_found
+     | _ -> ()
+   end;
+   match decl.type_manifest with
+   | Some body when decl.type_private = Public
+               || decl.type_kind <> Type_abstract
+-              || Btype.has_constr_row body -> (decl.type_params, body)
++              || Btype.has_constr_row body ->
++                  (decl.type_params, body, may_map snd decl.type_newtype_level)
+   (* The manifest type of Private abstract data types without
+      private row are still considered unknown to the type system.
+      Hence, this case is caught by the following clause that also handles
+@@ -308,7 +310,7 @@
+   match decl.type_manifest with
+   (* The manifest type of Private abstract data types can still get
+      an approximation using their manifest type. *)
+-  | Some body -> (decl.type_params, body)
++  | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
+   | _ -> raise Not_found
+ 
+ let find_modtype_expansion path env =
+@@ -453,32 +455,42 @@
+ and lookup_cltype =
+   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+ 
+-(* Level handling *)
++(* GADT instance tracking *)
+ 
+-(* The level map is a list of pairs describing separate segments (lv,lv'),
+-   lv < lv', organized in decreasing order.
+-   The definition level is obtained by mapping a level in a segment to the
+-   high limit of this segment.
+-   The definition level of a newtype should be greater or equal to
+-   the highest level of the newtypes in its manifest type.
+- *)
++let add_gadt_instance_level lv env =
++  {env with
++   gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances}
+ 
+-let rec map_level lv = function
+-  | [] -> lv
+-  | (lv1, lv2) :: rem ->
+-      if lv > lv2 then lv else
+-      if lv >= lv1 then lv2 else map_level lv rem
++let is_Tlink = function {desc = Tlink _} -> true | _ -> false
+ 
+-let map_newtype_level env lv = map_level lv env.level_map
++let gadt_instance_level env t =
++  let rec find_instance = function
++      [] -> None
++    | (lv, r) :: rem ->
++        if TypeSet.exists is_Tlink !r then
++          r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty;
++        if TypeSet.mem t !r then Some lv else find_instance rem
++  in find_instance env.gadt_instances
+ 
+-(* precondition: lv < lv' *)
+-let rec add_level lv lv' = function
+-  | [] -> [lv, lv']
+-  | (lv1, lv2) :: rem as l ->
+-      if lv2 < lv then (lv, lv') :: l else
+-      if lv' < lv1 then (lv1, lv2) :: add_level lv lv' rem
+-      else add_level (max lv lv1) (min lv' lv2) rem      
++let add_gadt_instances env lv tl =
++  let r =
++    try List.assoc lv env.gadt_instances with Not_found -> assert false in
++  r := List.fold_right TypeSet.add tl !r
+ 
++(* Only use this after expand_head! *)
++let add_gadt_instance_chain env lv t =
++  let r =
++    try List.assoc lv env.gadt_instances with Not_found -> assert false in
++  let rec add_instance t =
++    let t = repr t in
++    if not (TypeSet.mem t !r) then begin
++      r := TypeSet.add t !r;
++      match t.desc with
++        Tconstr (p, _, memo) ->
++          may add_instance (find_expans Private p !memo)
++      | _ -> ()
++    end
++  in add_instance t
+ 
+ (* Expand manifest module type names at the top of the given module type *)
+ 
+@@ -497,7 +509,7 @@
+ let constructors_of_type ty_path decl =
+   let handle_variants cstrs = 
+     Datarepr.constructor_descrs
+-      (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
++      (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+       cstrs decl.type_private
+   in
+   match decl.type_kind with
+@@ -510,7 +522,7 @@
+   match decl.type_kind with
+     Type_record(labels, rep) ->
+       Datarepr.label_descrs
+-        (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
++        (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+         labels rep decl.type_private
+   | Type_variant _ | Type_abstract -> []
+ 
+@@ -773,14 +785,13 @@
+ and add_cltype id ty env =
+   store_cltype id (Pident id) ty env
+ 
+-let add_local_constraint id info mlv env =
++let add_local_constraint id info elv env =
+   match info with
+-    {type_manifest = Some ty; type_newtype_level = Some lv} ->
+-      (* use the newtype level for this definition, lv is the old one *)
+-      let env = add_type id {info with type_newtype_level = Some mlv} env in
+-      let level_map =
+-        if lv < mlv then add_level lv mlv env.level_map else env.level_map in
+-      { env with local_constraints = true; level_map = level_map }
++    {type_manifest = Some ty; type_newtype_level = Some (lv, _)} ->
++      (* elv is the expansion level, lv is the definition level *)
++      let env =
++        add_type id {info with type_newtype_level = Some (lv, elv)} env in
++      { env with local_constraints = true }
+   | _ -> assert false
+ 
+ (* Insertion of bindings by name *)
+Index: typing/typecore.ml
+===================================================================
+--- typing/typecore.ml (revision 11214)
++++ typing/typecore.ml (working copy)
+@@ -1989,6 +1989,7 @@
+       end
+   | Pexp_newtype(name, sbody) ->
+       (* Create a fake abstract type declaration for name. *)
++      let level = get_current_level () in
+       let decl = {
+         type_params = [];
+         type_arity = 0;
+@@ -1996,7 +1997,7 @@
+         type_private = Public;
+         type_manifest = None;
+         type_variance = [];
+-        type_newtype_level = Some (get_current_level ());
++        type_newtype_level = Some (level, level);
+       }
+       in
+       let ty = newvar () in
+@@ -2421,6 +2422,7 @@
+   begin_def ();
+   Ident.set_current_time (get_current_level ()); 
+   let lev = Ident.current_time () in
++  let env = Env.add_gadt_instance_level lev env in
+   Ctype.init_def (lev+1000);
+   if !Clflags.principal then begin_def (); (* propagation of the argument *)
+   let ty_arg' = newvar () in
+Index: typing/typedecl.ml
+===================================================================
+--- typing/typedecl.ml (revision 11214)
++++ typing/typedecl.ml (working copy)
+@@ -404,7 +404,7 @@
+           else if to_check path' && not (List.mem path' prev_exp) then begin
+             try
+               (* Attempt expansion *)
+-              let (params0, body0) = Env.find_type_expansion path' env in
++              let (params0, body0, _) = Env.find_type_expansion path' env in
+               let (params, body) =
+                 Ctype.instance_parameterized_type params0 body0 in
+               begin
+Index: typing/types.mli
+===================================================================
+--- typing/types.mli   (revision 11214)
++++ typing/types.mli   (working copy)
+@@ -144,9 +144,9 @@
+     type_manifest: type_expr option;
+     type_variance: (bool * bool * bool) list;
+     (* covariant, contravariant, weakly contravariant *)
+-    type_newtype_level: int option }
++    type_newtype_level: (int * int) option }
++    (* definition level * expansion level *)
+ 
+-
+ and type_kind =
+     Type_abstract
+   | Type_record of
+Index: typing/ctype.ml
+===================================================================
+--- typing/ctype.ml    (revision 11214)
++++ typing/ctype.ml    (working copy)
+@@ -470,7 +470,7 @@
+         free_variables := (ty, real) :: !free_variables
+     | Tconstr (path, tl, _), Some env ->
+         begin try
+-          let (_, body) = Env.find_type_expansion path env in
++          let (_, body, _) = Env.find_type_expansion path env in
+           if (repr body).level <> generic_level then
+             free_variables := (ty, real) :: !free_variables
+         with Not_found -> ()
+@@ -687,7 +687,7 @@
+   try
+     match (Env.find_type p env).type_newtype_level with
+       | None -> Path.binding_time p
+-      | Some x -> x
++      | Some (x, _) -> x
+   with 
+     | _ -> 
+       (* no newtypes in predef *)
+@@ -696,9 +696,13 @@
+ let rec update_level env level ty =
+   let ty = repr ty in
+   if ty.level > level then begin
++    if !Clflags.principal && Env.has_local_constraints env then begin
++      match Env.gadt_instance_level env ty with
++        Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
++      | None -> ()
++    end;
+     match ty.desc with
+-      Tconstr(p, tl, abbrev)
+-      when level < Env.map_newtype_level env (get_level env p) ->
++      Tconstr(p, tl, abbrev) when level < get_level env p ->
+         (* Try first to replace an abbreviation by its expansion. *)
+         begin try
+           (* if is_newtype env p then raise Cannot_expand; *)
+@@ -1025,7 +1029,7 @@
+   | Some (env, newtype_lev) ->
+       let existentials = List.map copy cstr.cstr_existentials in
+       let process existential = 
+-        let decl = new_declaration (Some newtype_lev) None in
++        let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
+         let (id, new_env) =
+           Env.enter_type (get_new_abstract_name ()) decl !env in
+         env := new_env;
+@@ -1271,7 +1275,7 @@
+             end;
+           ty
+       | None ->
+-          let (params, body) =
++          let (params, body, lv) =
+             try find_type_expansion level path env with Not_found ->
+               raise Cannot_expand
+           in
+@@ -1284,6 +1288,15 @@
+               ty.desc <- Tvariant { row with row_name = Some (path, args) }
+           | _ -> ()
+           end;
++          (* For gadts, remember type as non exportable *)
++          if !Clflags.principal then begin
++            match lv with
++              Some lv -> Env.add_gadt_instances env lv [ty; ty']
++            | None ->
++                match Env.gadt_instance_level env ty with
++                  Some lv -> Env.add_gadt_instances env lv [ty']
++                | None -> ()
++          end;
+           ty'
+       end
+   | _ ->
+@@ -1306,15 +1319,7 @@
+ let try_expand_once env ty =
+   let ty = repr ty in
+   match ty.desc with
+-    Tconstr (p, _, _) ->
+-      let ty' = repr (expand_abbrev env ty) in
+-      if !Clflags.principal then begin
+-        match (Env.find_type p env).type_newtype_level with
+-          Some lv when ty.level < Env.map_newtype_level env lv  ->
+-            link_type ty ty'
+-        | _ -> ()
+-      end;
+-      ty'
++    Tconstr (p, _, _) -> repr (expand_abbrev env ty)
+   | _ -> raise Cannot_expand
+ 
+ let _ = forward_try_expand_once := try_expand_once
+@@ -1324,11 +1329,16 @@
+    May raise Unify, if a recursion was hidden in the type. *)
+ let rec try_expand_head env ty =
+   let ty' = try_expand_once env ty in
+-  begin try
+-    try_expand_head env ty'
+-  with Cannot_expand ->
+-    ty'
+-  end
++  let ty'' =
++    try try_expand_head env ty'
++    with Cannot_expand -> ty'
++  in
++  if !Clflags.principal then begin
++    match Env.gadt_instance_level env ty'' with
++      None    -> ()
++    | Some lv -> Env.add_gadt_instance_chain env lv ty
++  end;
++  ty''
+ 
+ (* Expand once the head of a type *)
+ let expand_head_once env ty =
+@@ -1405,7 +1415,7 @@
+ *)
+ let generic_abbrev env path =
+   try
+-    let (_, body) = Env.find_type_expansion path env in
++    let (_, body, _) = Env.find_type_expansion path env in
+     (repr body).level = generic_level
+   with
+     Not_found ->
+@@ -1742,7 +1752,7 @@
+ let reify env t =
+   let newtype_level = get_newtype_level () in
+   let create_fresh_constr lev row = 
+-      let decl = new_declaration (Some (newtype_level)) None in
++      let decl = new_declaration (Some (newtype_level, newtype_level)) None in
+       let name = 
+         let name = get_new_abstract_name () in 
+         if row then name ^ "#row" else name
+@@ -2065,7 +2075,7 @@
+         update_level !env t1.level t2;
+         link_type t1 t2
+     | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
+-          when Path.same p1 p2 && actual_mode !env = Old
++          when Path.same p1 p2 (* && actual_mode !env = Old *)
+             (* This optimization assumes that t1 does not expand to t2
+                (and conversely), so we fall back to the general case
+                when any of the types has a cached expansion. *)
+@@ -2091,6 +2101,15 @@
+   if unify_eq !env t1' t2' then () else
+ 
+   let t1 = repr t1 and t2 = repr t2 in
++  if !Clflags.principal then begin
++    match Env.gadt_instance_level !env t1',Env.gadt_instance_level !env t2' with
++      Some lv1, Some lv2 ->
++        if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
++        if lv2 > lv2 then Env.add_gadt_instance_chain !env lv2 t1
++    | Some lv1, None -> Env.add_gadt_instance_chain !env lv1 t2
++    | None, Some lv2 -> Env.add_gadt_instance_chain !env lv2 t1
++    | None, None     -> ()
++  end;
+   if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then
+     unify3 env t1 t1' t2 t2'
+   else
+Index: typing/env.mli
+===================================================================
+--- typing/env.mli     (revision 11214)
++++ typing/env.mli     (working copy)
+@@ -33,14 +33,19 @@
+ val find_cltype: Path.t -> t -> cltype_declaration
+ 
+ val find_type_expansion:
+-    ?use_local:bool -> ?level:int -> Path.t -> t -> type_expr list * type_expr
+-val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr
++    ?use_local:bool -> ?level:int -> Path.t -> t ->
++    type_expr list * type_expr * int option
++val find_type_expansion_opt:
++    Path.t -> t -> type_expr list * type_expr * int option
+ (* Find the manifest type information associated to a type for the sake
+    of the compiler's type-based optimisations. *)
+ val find_modtype_expansion: Path.t -> t -> Types.module_type
+ 
+ val has_local_constraints: t -> bool
+-val map_newtype_level: t -> int -> int
++val add_gadt_instance_level: int -> t -> t
++val gadt_instance_level: t -> type_expr -> int option
++val add_gadt_instances: t -> int -> type_expr list -> unit
++val add_gadt_instance_chain: t -> int -> type_expr -> unit
+ 
+ (* Lookup by long identifiers *)
+ 
+Index: typing/types.ml
+===================================================================
+--- typing/types.ml    (revision 11214)
++++ typing/types.ml    (working copy)
+@@ -146,8 +146,8 @@
+     type_private: private_flag;
+     type_manifest: type_expr option;
+     type_variance: (bool * bool * bool) list;
+-    type_newtype_level: int option }
+             (* covariant, contravariant, weakly contravariant *)
++    type_newtype_level: (int * int) option }
+ 
+ and type_kind =
+     Type_abstract
+Index: testsuite/tests/typing-gadts/test.ml
+===================================================================
+--- testsuite/tests/typing-gadts/test.ml       (revision 11214)
++++ testsuite/tests/typing-gadts/test.ml       (working copy)
+@@ -159,17 +159,21 @@
+ 
+ let ky x y = ignore (x = y); x ;;
+ 
++let test : type a. a t -> a =
++  function Int -> ky (1 : a) 1
++;;
++
+ let test : type a. a t -> a = fun x ->
+-  let r = match x with Int -> ky (1 : a) 1
++  let r = match x with Int -> ky (1 : a) 1  (* fails *)
+   in r
+ ;;
+ let test : type a. a t -> a = fun x ->
+-  let r = match x with Int -> ky 1 (1 : a)
++  let r = match x with Int -> ky 1 (1 : a)  (* fails *)
+   in r
+ ;;
+ let test : type a. a t -> a = fun x ->
+-  let r = match x with Int -> (1 : a)
+-  in r (* fails too *)
++  let r = match x with Int -> (1 : a)       (* ok! *)
++  in r
+ ;;
+ let test : type a. a t -> a = fun x ->
+   let r : a = match x with Int -> 1
+@@ -178,7 +182,7 @@
+ let test2 : type a. a t -> a option = fun x ->
+   let r = ref None in
+   begin match x with Int -> r := Some (1 : a) end;
+-  !r (* normalized to int option *)
++  !r (* ok *)
+ ;;
+ let test2 : type a. a t -> a option = fun x ->
+   let r : a option ref = ref None in
+@@ -190,19 +194,19 @@
+   let u = ref None in
+   begin match x with Int -> r := Some 1; u := !r end;
+   !u
+-;; (* fail *)
++;; (* ok (u non-ambiguous) *)
+ let test2 : type a. a t -> a option = fun x ->
+   let r : a option ref = ref None in
+   let u = ref None in
+   begin match x with Int -> u := Some 1; r := !u end;
+   !u
+-;; (* fail *)
++;; (* fails because u : (int | a) option ref *)
+ let test2 : type a. a t -> a option = fun x ->
+   let u = ref None in
+   let r : a option ref = ref None in
+   begin match x with Int -> r := Some 1; u := !r end;
+   !u
+-;; (* fail *)
++;; (* ok *)
+ let test2 : type a. a t -> a option = fun x ->
+   let u = ref None in
+   let a =
+@@ -210,32 +214,32 @@
+     begin match x with Int -> r := Some 1; u := !r end;
+     !u
+   in a
+-;; (* fail *)
++;; (* ok *)
+ 
+ (* Effect of external consraints *)
+ 
+ let f (type a) (x : a t) y =
+   ignore (y : a);
+-  let r = match x with Int -> (y : a) in (* fails *)
++  let r = match x with Int -> (y : a) in (* ok *)
+   r
+ ;;
+ let f (type a) (x : a t) y =
+   let r = match x with Int -> (y : a) in
+-  ignore (y : a); (* fails *)
++  ignore (y : a); (* ok *)
+   r
+ ;;
+ let f (type a) (x : a t) y =
+   ignore (y : a);
+-  let r = match x with Int -> y in
++  let r = match x with Int -> y in (* ok *)
+   r
+ ;;
+ let f (type a) (x : a t) y =
+   let r = match x with Int -> y in
+-  ignore (y : a);
++  ignore (y : a); (* ok *)
+   r
+ ;;
+ let f (type a) (x : a t) (y : a) =
+-  match x with Int -> y (* should return an int! *)
++  match x with Int -> y (* returns 'a *)
+ ;;
+ 
+ (* Pattern matching *)
+@@ -307,4 +311,4 @@
+   | {left=TE TC; right=D [|1.0|]} -> 14
+   | {left=TA; right=D 0} -> -1
+   | {left=TA; right=D z} -> z
+-;; (* warn *)
++;; (* ok *)

diff --git a/experimental/garrigue/marshal_objects.diffs b/experimental/garrigue/marshal_objects.diffs
new file mode 100644 (file)
index 0000000..bb9b4dd
--- /dev/null
+++ b/experimental/garrigue/marshal_objects.diffs
@@ -0,0 +1,800 @@
+? bytecomp/alpha_eq.ml
+Index: bytecomp/lambda.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v
+retrieving revision 1.44
+diff -u -r1.44 lambda.ml
+--- bytecomp/lambda.ml 25 Aug 2005 15:35:16 -0000      1.44
++++ bytecomp/lambda.ml 2 Feb 2006 05:08:56 -0000
+@@ -287,9 +287,10 @@
+     let compare = compare
+   end)
+ 
+-let free_ids get l =
++let free_ids get used l =
+   let fv = ref IdentSet.empty in
+   let rec free l =
++    let old = !fv in
+     iter free l;
+     fv := List.fold_right IdentSet.add (get l) !fv;
+     match l with
+@@ -307,17 +308,20 @@
+         fv := IdentSet.remove v !fv
+     | Lassign(id, e) ->
+         fv := IdentSet.add id !fv
++    | Lifused(id, e) ->
++        if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv
+     | Lvar _ | Lconst _ | Lapply _
+     | Lprim _ | Lswitch _ | Lstaticraise _
+     | Lifthenelse _ | Lsequence _ | Lwhile _
+-    | Lsend _ | Levent _ | Lifused _ -> ()
++    | Lsend _ | Levent _ -> ()
+   in free l; !fv
+ 
+-let free_variables l =
+-  free_ids (function Lvar id -> [id] | _ -> []) l
++let free_variables ?(ifused=false) l =
++  free_ids (function Lvar id -> [id] | _ -> []) ifused l
+ 
+ let free_methods l =
+-  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
++  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> [])
++    false l
+ 
+ (* Check if an action has a "when" guard *)
+ let raise_count = ref 0
+Index: bytecomp/lambda.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v
+retrieving revision 1.42
+diff -u -r1.42 lambda.mli
+--- bytecomp/lambda.mli        25 Aug 2005 15:35:16 -0000      1.42
++++ bytecomp/lambda.mli        2 Feb 2006 05:08:56 -0000
+@@ -177,7 +177,7 @@
+ 
+ val iter: (lambda -> unit) -> lambda -> unit
+ module IdentSet: Set.S with type elt = Ident.t
+-val free_variables: lambda -> IdentSet.t
++val free_variables: ?ifused:bool -> lambda -> IdentSet.t
+ val free_methods: lambda -> IdentSet.t
+ 
+ val transl_path: Path.t -> lambda
+Index: bytecomp/translclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
+retrieving revision 1.38
+diff -u -r1.38 translclass.ml
+--- bytecomp/translclass.ml    13 Aug 2005 20:59:37 -0000      1.38
++++ bytecomp/translclass.ml    2 Feb 2006 05:08:56 -0000
+@@ -46,6 +46,10 @@
+ 
+ let lfield v i = Lprim(Pfield i, [Lvar v])
+ 
++let ltuple l = Lprim(Pmakeblock(0,Immutable), l)
++
++let lprim name args = Lapply(oo_prim name, args)
++
+ let transl_label l = share (Const_immstring l)
+ 
+ let rec transl_meth_list lst =
+@@ -68,8 +72,8 @@
+                                                     Lvar offset])])]))
+ 
+ let transl_val tbl create name =
+-  Lapply (oo_prim (if create then "new_variable" else "get_variable"),
+-          [Lvar tbl; transl_label name])
++  lprim (if create then "new_variable" else "get_variable")
++    [Lvar tbl; transl_label name]
+ 
+ let transl_vals tbl create vals rem =
+   List.fold_right
+@@ -82,7 +86,7 @@
+     (fun (nm, id) rem ->
+        try
+          (nm, id,
+-          Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
++          lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)])
+          :: rem
+        with Not_found -> rem)
+     inh_meths []
+@@ -97,17 +101,15 @@
+   let (inh_init, obj_init, has_init) = init obj' in
+   if obj_init = lambda_unit then
+     (inh_init,
+-     Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
+-                      else"create_object_opt"),
+-             [obj; Lvar cl]))
++     lprim (if has_init then "create_object_and_run_initializers"
++            else"create_object_opt")
++       [obj; Lvar cl])
+   else begin
+    (inh_init,
+-    Llet(Strict, obj',
+-            Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
++    Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl],
+          Lsequence(obj_init,
+                    if not has_init then Lvar obj' else
+-                   Lapply (oo_prim "run_initializers_opt",
+-                         [obj; Lvar obj'; Lvar cl]))))
++                   lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl])))
+   end
+ 
+ let rec build_object_init cl_table obj params inh_init obj_init cl =
+@@ -203,14 +205,13 @@
+ 
+ 
+ let bind_method tbl lab id cl_init =
+-  Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
+-                              [Lvar tbl; transl_label lab]),
++  Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab],
+        cl_init)
+ 
+-let bind_methods tbl meths vals cl_init =
+-  let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
++let bind_methods tbl methl vals cl_init =
+   let len = List.length methl and nvals = List.length vals in
+-  if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
++  if len < 2 && nvals = 0 then
++    List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else
+   if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
+   let ids = Ident.create "ids" in
+   let i = ref len in
+@@ -229,21 +230,19 @@
+              vals' cl_init)
+   in
+   Llet(StrictOpt, ids,
+-       Lapply (oo_prim getter,
+-               [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
++       lprim getter
++         ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
+        List.fold_right
+-         (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
++         (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam))
+          methl cl_init)
+ 
+ let output_methods tbl methods lam =
+   match methods with
+     [] -> lam
+   | [lab; code] ->
+-      lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
++      lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam
+   | _ ->
+-      lsequence (Lapply(oo_prim "set_methods",
+-                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
+-        lam
++      lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam
+ 
+ let rec ignore_cstrs cl =
+   match cl.cl_desc with
+@@ -266,7 +265,8 @@
+            Llet (Strict, obj_init, 
+                  Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
+                       if top then [Lprim(Pfield 3, [lpath])] else []),
+-                 bind_super cla super cl_init))
++                 bind_super cla super cl_init),
++           [], [])
+       | _ ->
+           assert false
+       end
+@@ -278,10 +278,11 @@
+             match field with
+               Cf_inher (cl, vals, meths) ->
+                 let cl_init = output_methods cla methods cl_init in
+-                let inh_init, cl_init =
++                let (inh_init, cl_init, meths', vals') =
+                   build_class_init cla false
+                     (vals, meths_super cla str.cl_meths meths)
+                     inh_init cl_init msubst top cl in
++                let cl_init = bind_methods cla meths' vals' cl_init in
+                 (inh_init, cl_init, [], values)
+             | Cf_val (name, id, exp) ->
+                 (inh_init, cl_init, methods, (name, id)::values)
+@@ -304,29 +305,37 @@
+                 (inh_init, cl_init, methods, vals @ values)
+             | Cf_init exp ->
+                 (inh_init,
+-                 Lsequence(Lapply (oo_prim "add_initializer",
+-                                   Lvar cla :: msubst false (transl_exp exp)),
++                 Lsequence(lprim "add_initializer"
++                             (Lvar cla :: msubst false (transl_exp exp)),
+                            cl_init),
+                  methods, values))
+           str.cl_field
+           (inh_init, cl_init, [], [])
+       in
+       let cl_init = output_methods cla methods cl_init in
+-      (inh_init, bind_methods cla str.cl_meths values cl_init)
++      (* inh_init, bind_methods cla str.cl_meths values cl_init *)
++      let methods =  Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in
++      (inh_init, cl_init, methods, values)
+   | Tclass_fun (pat, vals, cl, _) ->
+-      let (inh_init, cl_init) =
++      let (inh_init, cl_init, methods, values) =
+         build_class_init cla cstr super inh_init cl_init msubst top cl
+       in
++      let fv = free_variables ~ifused:true cl_init in
++      let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
+       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
+-      (inh_init, transl_vals cla true vals cl_init)
++      (* inh_init, transl_vals cla true vals cl_init *)
++      (inh_init, cl_init, methods, vals @ values)
+   | Tclass_apply (cl, exprs) ->
+       build_class_init cla cstr super inh_init cl_init msubst top cl
+   | Tclass_let (rec_flag, defs, vals, cl) ->
+-      let (inh_init, cl_init) =
++      let (inh_init, cl_init, methods, values) =
+         build_class_init cla cstr super inh_init cl_init msubst top cl
+       in
++      let fv = free_variables ~ifused:true cl_init in
++      let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
+       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
+-      (inh_init, transl_vals cla true vals cl_init)
++      (* inh_init, transl_vals cla true vals cl_init *)
++      (inh_init, cl_init, methods, vals @ values)
+   | Tclass_constraint (cl, vals, meths, concr_meths) ->
+       let virt_meths =
+         List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
+@@ -358,23 +367,34 @@
+               cl_init valids in
+           (inh_init,
+            Llet (Strict, inh, 
+-               Lapply(oo_prim "inherits", narrow_args @
+-                      [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
++               lprim "inherits"
++                   (narrow_args @
++                    [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
+                  Llet(StrictOpt, obj_init, lfield inh 0,
+                  Llet(Alias, inh_vals, lfield inh 1,
+-                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
++                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))),
++          [], [])
+       | _ ->
+         let core cl_init =
+             build_class_init cla true super inh_init cl_init msubst top cl
+         in
+         if cstr then core cl_init else
+-          let (inh_init, cl_init) =
+-            core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
++          let (inh_init, cl_init, methods, values) =
++            core (Lsequence (lprim "widen" [Lvar cla], cl_init))
+           in
+-          (inh_init,
+-           Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
++          let cl_init = bind_methods cla methods values cl_init in
++          (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], [])
+       end
+ 
++let build_class_init cla env inh_init obj_init msubst top cl =
++  let inh_init = List.rev inh_init in
++  let (inh_init, cl_init, methods, values) =
++    build_class_init cla true ([],[]) inh_init obj_init msubst top cl in
++  assert (inh_init = []);
++  if IdentSet.mem env (free_variables ~ifused:true cl_init)
++  then bind_methods cla methods (("", env) :: values) cl_init
++  else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init)
++
+ let rec build_class_lets cl =
+   match cl.cl_desc with
+     Tclass_let (rec_flag, defs, vals, cl) ->
+@@ -459,16 +479,16 @@
+     Strict, new_init, lfunction [obj_init] obj_init',
+     Llet(
+     Alias, cla, transl_path path,
+-    Lprim(Pmakeblock(0, Immutable),
+-          [Lapply(Lvar new_init, [lfield cla 0]);
+-           lfunction [table]
+-             (Llet(Strict, env_init,
+-                   Lapply(lfield cla 1, [Lvar table]),
+-                   lfunction [envs]
+-                     (Lapply(Lvar new_init,
+-                             [Lapply(Lvar env_init, [Lvar envs])]))));
+-           lfield cla 2;
+-           lfield cla 3])))
++    ltuple
++      [Lapply(Lvar new_init, [lfield cla 0]);
++       lfunction [table]
++         (Llet(Strict, env_init,
++               Lapply(lfield cla 1, [Lvar table]),
++               lfunction [envs]
++                 (Lapply(Lvar new_init,
++                         [Lapply(Lvar env_init, [Lvar envs])]))));
++       lfield cla 2;
++       lfield cla 3]))
+   with Exit ->
+     lambda_unit
+ 
+@@ -541,7 +561,7 @@
+   open CamlinternalOO
+   let builtin_meths arr self env env2 body =
+     let builtin, args = builtin_meths self env env2 body in
+-    if not arr then [Lapply(oo_prim builtin, args)] else
++    if not arr then [lprim builtin args] else
+     let tag = match builtin with
+       "get_const" -> GetConst
+     | "get_var"   -> GetVar
+@@ -599,7 +619,8 @@
+ 
+   (* Prepare for heavy environment handling *)
+   let tables = Ident.create (Ident.name cl_id ^ "_tables") in
+-  let (top_env, req) = oo_add_class tables in
++  let table_init = ref None in
++  let (top_env, req) = oo_add_class tables table_init in
+   let top = not req in
+   let cl_env, llets = build_class_lets cl in
+   let new_ids = if top then [] else Env.diff top_env cl_env in
+@@ -633,6 +654,7 @@
+         begin try
+           (* Doesn't seem to improve size for bytecode *)
+           (* if not !Clflags.native_code then raise Not_found; *)
++          if !Clflags.debug then raise Not_found;
+           builtin_meths arr [self] env env2 (lfunction args body')
+         with Not_found ->
+           [lfunction (self :: args)
+@@ -665,15 +687,8 @@
+     build_object_init_0 cla [] cl copy_env subst_env top ids in
+   if not (Translcore.check_recursive_lambda ids obj_init) then
+     raise(Error(cl.cl_loc, Illegal_class_expr));
+-  let inh_init' = List.rev inh_init in
+-  let (inh_init', cl_init) =
+-    build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
+-  in
+-  assert (inh_init' = []);
+-  let table = Ident.create "table"
+-  and class_init = Ident.create (Ident.name cl_id ^ "_init")
+-  and env_init = Ident.create "env_init"
+-  and obj_init = Ident.create "obj_init" in
++  let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in
++  let obj_init = Ident.create "obj_init" in
+   let pub_meths =
+     List.sort
+       (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
+@@ -685,42 +700,44 @@
+       let name' = List.assoc tag rev_map in
+       if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
+     tags pub_meths;
++  let pos = cl.cl_loc.Location.loc_end in
++  let filepos = [transl_label pos.Lexing.pos_fname;
++                 Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in
+   let ltable table lam =
+-    Llet(Strict, table,
+-         Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
++    Llet(Strict, table, lprim "create_table" [transl_meth_list pub_meths], lam)
+   and ldirect obj_init =
+     Llet(Strict, obj_init, cl_init,
+-         Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
++         Lsequence(lprim "init_class_shared" (Lvar cla :: filepos),
+                    Lapply(Lvar obj_init, [lambda_unit])))
+   in
+   (* Simplest case: an object defined at toplevel (ids=[]) *)
+   if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
+ 
++  let table = Ident.create "table"
++  and class_init = Ident.create (Ident.name cl_id ^ "_init")
++  and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in
++  let cl_init_fun = Lfunction(Curried, [cla], cl_init) in
+   let concrete =
+     ids = [] ||
+     Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
+-  and lclass lam =
+-    let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
++  and lclass cl_init lam =
+     Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
+   and lbody fv =
+     if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
+-      Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
+-                                  Lvar class_init])
++      lprim "make_class"
++        (transl_meth_list pub_meths :: Lvar class_init :: filepos)
+     else
+       ltable table (
+       Llet(
+       Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
+-      Lsequence(
+-      Lapply (oo_prim "init_class", [Lvar table]),
+-      Lprim(Pmakeblock(0, Immutable),
+-          [Lapply(Lvar env_init, [lambda_unit]);
+-           Lvar class_init; Lvar env_init; lambda_unit]))))
++      Lsequence(lprim "init_class_shared" (Lvar table :: filepos),
++                ltuple [Lapply(Lvar env_init, [lambda_unit]);
++                      Lvar class_init; Lvar env_init; lambda_unit])))
+   and lbody_virt lenvs =
+-    Lprim(Pmakeblock(0, Immutable),
+-          [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
++    ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs]
+   in
+   (* Still easy: a class defined at toplevel *)
+-  if top && concrete then lclass lbody else
++  if top && concrete then lclass (llets cl_init_fun) lbody else
+   if top then llets (lbody_virt lambda_unit) else
+ 
+   (* Now for the hard stuff: prepare for table cacheing *)
+@@ -733,23 +750,16 @@
+   let lenv =
+     let menv =
+       if !new_ids_meths = [] then lambda_unit else
+-      Lprim(Pmakeblock(0, Immutable),
+-            List.map (fun id -> Lvar id) !new_ids_meths) in
++      ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in
+     if !new_ids_init = [] then menv else
+-    Lprim(Pmakeblock(0, Immutable),
+-          menv :: List.map (fun id -> Lvar id) !new_ids_init)
++    ltuple (menv :: List.map (fun id -> Lvar id) !new_ids_init)
+   and linh_envs =
+     List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
+       (List.rev inh_init)
+   in
+   let make_envs lam =
+     Llet(StrictOpt, envs,
+-         (if linh_envs = [] then lenv else
+-         Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)),
+-         lam)
+-  and def_ids cla lam =
+-    Llet(StrictOpt, env2,
+-         Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
++         (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)),
+          lam)
+   in
+   let inh_paths =
+@@ -757,46 +767,53 @@
+       (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
+   let inh_keys =
+     List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
+-  let lclass lam =
+-    Llet(Strict, class_init,
+-         Lfunction(Curried, [cla], def_ids cla cl_init), lam)
++  let lclass_init lam =
++    Llet(Strict, class_init, cl_init_fun, lam)
+   and lcache lam =
+     if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
+-    Llet(Strict, cached,
+-         Lapply(oo_prim "lookup_tables",
+-                [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
++    Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple inh_keys],
+          lam)
+   and lset cached i lam =
+     Lprim(Psetfield(i, true), [Lvar cached; lam])
+   in
+-  let ldirect () =
+-    ltable cla
+-      (Llet(Strict, env_init, def_ids cla cl_init,
+-            Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
+-                      lset cached 0 (Lvar env_init))))
+-  and lclass_virt () =
+-    lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
++  let ldirect prim pos =
++    ltable cla (
++    Llet(Strict, env_init, cl_init,
++         Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init)))
++  and lclass_concrete cached =
++    ltuple [Lapply (lfield cached 0, [lenvs]);
++            lfield cached 1; lfield cached 0; lenvs]
+   in
++
+   llets (
+-  lcache (
+-  Lsequence(
+-  Lifthenelse(lfield cached 0, lambda_unit,
+-              if ids = [] then ldirect () else
+-              if not concrete then lclass_virt () else
+-              lclass (
+-              Lapply (oo_prim "make_class_store",
+-                      [transl_meth_list pub_meths;
+-                       Lvar class_init; Lvar cached]))),
+   make_envs (
+-  if ids = [] then Lapply(lfield cached 0, [lenvs]) else
+-  Lprim(Pmakeblock(0, Immutable),
+-        if concrete then
+-          [Lapply(lfield cached 0, [lenvs]);
+-           lfield cached 1;
+-           lfield cached 0;
+-           lenvs]
+-        else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
+-       )))))
++  if inh_paths = [] && concrete then
++    if ids = [] then begin
++      table_init := Some (ldirect "init_class_shared" filepos);
++      Lapply (Lvar tables, [lenvs])
++    end else begin
++      let init =
++        lclass cl_init_fun (fun _ ->
++          lprim "make_class_env"
++            (transl_meth_list pub_meths :: Lvar class_init :: filepos))
++      in table_init := Some init;
++      lclass_concrete tables
++    end
++  else begin
++    lcache (
++    Lsequence(
++    Lifthenelse(lfield cached 0, lambda_unit,
++                if ids = [] then lset cached 0 (ldirect "init_class" []) else
++                if not concrete then lset cached 0 cl_init_fun else
++                lclass_init (
++                lprim "make_class_store"
++                  [transl_meth_list pub_meths; Lvar class_init; Lvar cached])),
++    llets (
++    make_envs (
++    if ids = [] then Lapply(lfield cached 0, [lenvs]) else
++    if concrete then lclass_concrete cached else
++    ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs]))))
++  end))
+ 
+ (* Wrapper for class compilation *)
+ 
+Index: bytecomp/translobj.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v
+retrieving revision 1.9
+diff -u -r1.9 translobj.ml
+--- bytecomp/translobj.ml      26 May 2004 11:10:51 -0000      1.9
++++ bytecomp/translobj.ml      2 Feb 2006 05:08:56 -0000
+@@ -88,7 +88,6 @@
+ 
+ (* Insert labels *)
+ 
+-let string s = Lconst (Const_base (Const_string s))
+ let int n = Lconst (Const_base (Const_int n))
+ 
+ let prim_makearray =
+@@ -124,8 +123,8 @@
+ let top_env = ref Env.empty
+ let classes = ref []
+ 
+-let oo_add_class id =
+-  classes := id :: !classes;
++let oo_add_class id init =
++  classes := (id, init) :: !classes;
+   (!top_env, !cache_required)
+ 
+ let oo_wrap env req f x =
+@@ -141,10 +140,12 @@
+     let lambda = f x in
+     let lambda =
+       List.fold_left
+-        (fun lambda id ->
++        (fun lambda (id, init) ->
+           Llet(StrictOpt, id,
+-               Lprim(Pmakeblock(0, Mutable),
+-                     [lambda_unit; lambda_unit; lambda_unit]),
++               (match !init with
++                 Some lam -> lam
++               | None -> Lprim(Pmakeblock(0, Mutable),
++                               [lambda_unit; lambda_unit; lambda_unit])),
+                lambda))
+         lambda !classes
+     in
+Index: bytecomp/translobj.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v
+retrieving revision 1.6
+diff -u -r1.6 translobj.mli
+--- bytecomp/translobj.mli     26 May 2004 11:10:51 -0000      1.6
++++ bytecomp/translobj.mli     2 Feb 2006 05:08:56 -0000
+@@ -25,4 +25,4 @@
+     Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
+ 
+ val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
+-val oo_add_class: Ident.t -> Env.t * bool
++val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool
+Index: byterun/compare.h
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v
+retrieving revision 1.2
+diff -u -r1.2 compare.h
+--- byterun/compare.h  31 Dec 2003 14:20:35 -0000      1.2
++++ byterun/compare.h  2 Feb 2006 05:08:56 -0000
+@@ -17,5 +17,6 @@
+ #define CAML_COMPARE_H
+ 
+ CAMLextern int caml_compare_unordered;
++CAMLextern value caml_compare(value, value);
+ 
+ #endif /* CAML_COMPARE_H */
+Index: byterun/extern.c
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v
+retrieving revision 1.59
+diff -u -r1.59 extern.c
+--- byterun/extern.c   4 Jan 2006 16:55:49 -0000       1.59
++++ byterun/extern.c   2 Feb 2006 05:08:56 -0000
+@@ -411,6 +411,22 @@
+       extern_record_location(v);
+       break;
+     }
++    case Object_tag: {
++      value field0;
++      mlsize_t i;
++      i = Wosize_val(Field(v, 0)) - 1;
++      field0 = Field(Field(v, 0),i);
++      if (Wosize_val(field0) > 0) {
++        writecode32(CODE_OBJECT, Wosize_hd (hd));
++        extern_record_location(v);
++        extern_rec(field0);
++        for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
++        v = Field(v, i);
++        goto tailcall;
++      }
++      if (!extern_closures)
++        extern_invalid_argument("output_value: dynamic class");
++    } /* may fall through */
+     default: {
+       value field0;
+       mlsize_t i;
+Index: byterun/intern.c
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v
+retrieving revision 1.60
+diff -u -r1.60 intern.c
+--- byterun/intern.c   22 Sep 2005 14:21:50 -0000      1.60
++++ byterun/intern.c   2 Feb 2006 05:08:56 -0000
+@@ -28,6 +28,8 @@
+ #include "mlvalues.h"
+ #include "misc.h"
+ #include "reverse.h"
++#include "callback.h"
++#include "compare.h"
+ 
+ static unsigned char * intern_src;
+ /* Reading pointer in block holding input data. */
+@@ -98,6 +100,25 @@
+ #define readblock(dest,len) \
+   (memmove((dest), intern_src, (len)), intern_src += (len))
+ 
++static value get_method_table (value key)
++{
++  static value *classes = NULL;
++  value current;
++  if (classes == NULL) {
++    classes = caml_named_value("caml_oo_classes");
++    if (classes == NULL) return 0;
++    caml_register_global_root(classes);
++  }
++  for (current = Field(*classes, 0); Is_block(current);
++       current = Field(current, 1))
++  {
++    value head = Field(current, 0);
++    if (caml_compare(key, Field(head, 0)) == Val_int(0))
++      return Field(head, 1);
++  }
++  return 0;
++}
++
+ static void intern_cleanup(void)
+ {
+   if (intern_input_malloced) caml_stat_free(intern_input);
+@@ -315,6 +336,24 @@
+         Custom_ops_val(v) = ops;
+         intern_dest += 1 + size;
+         break;
++      case CODE_OBJECT:
++        size = read32u();
++        v = Val_hp(intern_dest);
++        *dest = v;
++        if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
++        dest = (value *) (intern_dest + 1);
++        *intern_dest = Make_header(size, Object_tag, intern_color);
++        intern_dest += 1 + size;
++        intern_rec(dest);
++        *dest = get_method_table(*dest);
++        if (*dest == 0) {
++          intern_cleanup();
++          caml_failwith("input_value: unknown class");
++        }
++        for(size--, dest++; size > 1; size--, dest++)
++          intern_rec(dest);
++        goto tailcall;
++        
+       default:
+         intern_cleanup();
+         caml_failwith("input_value: ill-formed message");
+Index: byterun/intext.h
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v
+retrieving revision 1.32
+diff -u -r1.32 intext.h
+--- byterun/intext.h   22 Sep 2005 14:21:50 -0000      1.32
++++ byterun/intext.h   2 Feb 2006 05:08:56 -0000
+@@ -56,6 +56,7 @@
+ #define CODE_CODEPOINTER 0x10
+ #define CODE_INFIXPOINTER 0x11
+ #define CODE_CUSTOM 0x12
++#define CODE_OBJECT 0x14
+ 
+ #if ARCH_FLOAT_ENDIANNESS == 0x76543210
+ #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG
+Index: stdlib/camlinternalOO.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
+retrieving revision 1.14
+diff -u -r1.14 camlinternalOO.ml
+--- stdlib/camlinternalOO.ml   25 Oct 2005 18:34:07 -0000      1.14
++++ stdlib/camlinternalOO.ml   2 Feb 2006 05:08:56 -0000
+@@ -305,10 +305,38 @@
+     public_methods;
+   table
+ 
++(*
++let create_table_variables pub_meths priv_meths vars =
++  let tbl = create_table pub_meths in
++  let pub_meths = to_array pub_meths
++  and priv_meths = to_array priv_meths
++  and vars = to_array vars in
++  let len = 2 + Array.length pub_meths + Array.length priv_meths in
++  let res = Array.create len tbl in
++  let mv = new_methods_variables tbl pub_meths vars in
++  Array.blit mv 0 res 1;
++  res
++*)
++
+ let init_class table =
+   inst_var_count := !inst_var_count + table.size - 1;
+   table.initializers <- List.rev table.initializers;
+-  resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
++  let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in
++  (* keep 1 more for extra info *)
++  let len = if len > Array.length table.methods then len else len+1 in
++  resize table len
++
++let classes = ref []
++let () = Callback.register "caml_oo_classes" classes
++
++let init_class_shared table (file : string) (pos : int) =
++  init_class table;
++  let rec unique_pos pos =
++    if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000)
++    else pos in
++  let pos = unique_pos pos in
++  table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos);
++  classes := ((file, pos), table.methods) :: !classes
+ 
+ let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
+   narrow cla vals virt_meths concr_meths;
+@@ -319,12 +347,18 @@
+    Array.map (fun nm -> get_method cla (get_method_label cla nm))
+      (to_array concr_meths))
+ 
+-let make_class pub_meths class_init =
++let make_class pub_meths class_init file pos =
+   let table = create_table pub_meths in
+   let env_init = class_init table in
+-  init_class table;
++  init_class_shared table file pos;
+   (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
+ 
++let make_class_env pub_meths class_init file pos =
++  let table = create_table pub_meths in
++  let env_init = class_init table in
++  init_class_shared table file pos;
++  (env_init, class_init)
++
+ type init_table = { mutable env_init: t; mutable class_init: table -> t }
+ 
+ let make_class_store pub_meths class_init init_table =
+Index: stdlib/camlinternalOO.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
+retrieving revision 1.9
+diff -u -r1.9 camlinternalOO.mli
+--- stdlib/camlinternalOO.mli  25 Oct 2005 18:34:07 -0000      1.9
++++ stdlib/camlinternalOO.mli  2 Feb 2006 05:08:56 -0000
+@@ -43,14 +43,20 @@
+ val add_initializer : table -> (obj -> unit) -> unit
+ val dummy_table : table
+ val create_table : string array -> table
++(* val create_table_variables :
++    string array -> string array -> string array -> table *)
+ val init_class : table -> unit
++val init_class_shared : table -> string -> int -> unit
+ val inherits :
+     table -> string array -> string array -> string array ->
+     (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
+     (Obj.t * int array * closure array)
+ val make_class :
+-    string array -> (table -> Obj.t -> t) ->
++    string array -> (table -> Obj.t -> t) -> string -> int ->
+     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
++val make_class_env :
++    string array -> (table -> Obj.t -> t) -> string -> int ->
++    (Obj.t -> t) * (table -> Obj.t -> t)
+ type init_table
+ val make_class_store :
+     string array -> (table -> t) -> init_table -> unit

diff --git a/experimental/garrigue/module-errors.diffs b/experimental/garrigue/module-errors.diffs
new file mode 100644 (file)
index 0000000..2f8c2bc
--- /dev/null
+++ b/experimental/garrigue/module-errors.diffs
@@ -0,0 +1,403 @@
+Index: typing/includemod.ml
+===================================================================
+--- typing/includemod.ml       (revision 11161)
++++ typing/includemod.ml       (working copy)
+@@ -19,7 +19,7 @@
+ open Types
+ open Typedtree
+ 
+-type error =
++type symptom =
+     Missing_field of Ident.t
+   | Value_descriptions of Ident.t * value_description * value_description
+   | Type_declarations of Ident.t * type_declaration
+@@ -38,6 +38,10 @@
+       Ctype.class_match_failure list
+   | Unbound_modtype_path of Path.t
+ 
++type pos =
++    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
++type error = pos list * symptom
++
+ exception Error of error list
+ 
+ (* All functions "blah env x1 x2" check that x1 is included in x2,
+@@ -46,51 +50,52 @@
+ 
+ (* Inclusion between value descriptions *)
+ 
+-let value_descriptions env subst id vd1 vd2 =
++let value_descriptions env cxt subst id vd1 vd2 =
+   let vd2 = Subst.value_description subst vd2 in
+   try
+     Includecore.value_descriptions env vd1 vd2
+   with Includecore.Dont_match ->
+-    raise(Error[Value_descriptions(id, vd1, vd2)])
++    raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
+ 
+ (* Inclusion between type declarations *)
+ 
+-let type_declarations env subst id decl1 decl2 =
++let type_declarations env cxt subst id decl1 decl2 =
+   let decl2 = Subst.type_declaration subst decl2 in
+   let err = Includecore.type_declarations env id decl1 decl2 in
+-  if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)])
++  if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
+ 
+ (* Inclusion between exception declarations *)
+ 
+-let exception_declarations env subst id decl1 decl2 =
++let exception_declarations env cxt subst id decl1 decl2 =
+   let decl2 = Subst.exception_declaration subst decl2 in
+   if Includecore.exception_declarations env decl1 decl2
+   then ()
+-  else raise(Error[Exception_declarations(id, decl1, decl2)])
++  else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
+ 
+ (* Inclusion between class declarations *)
+ 
+-let class_type_declarations env subst id decl1 decl2 =
++let class_type_declarations env cxt subst id decl1 decl2 =
+   let decl2 = Subst.cltype_declaration subst decl2 in
+   match Includeclass.class_type_declarations env decl1 decl2 with
+     []     -> ()
+-  | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)])
++  | reason ->
++      raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)])
+ 
+-let class_declarations env subst id decl1 decl2 =
++let class_declarations env cxt subst id decl1 decl2 =
+   let decl2 = Subst.class_declaration subst decl2 in
+   match Includeclass.class_declarations env decl1 decl2 with
+     []     -> ()
+-  | reason -> raise(Error[Class_declarations(id, decl1, decl2, reason)])
++  | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)])
+ 
+ (* Expand a module type identifier when possible *)
+ 
+ exception Dont_match
+ 
+-let expand_module_path env path =
++let expand_module_path env cxt path =
+   try
+     Env.find_modtype_expansion path env
+   with Not_found ->
+-    raise(Error[Unbound_modtype_path path])
++    raise(Error[cxt, Unbound_modtype_path path])
+ 
+ (* Extract name, kind and ident from a signature item *)
+ 
+@@ -128,28 +133,29 @@
+    Return the restriction that transforms a value of the smaller type
+    into a value of the bigger type. *)
+ 
+-let rec modtypes env subst mty1 mty2 =
++let rec modtypes env cxt subst mty1 mty2 =
+   try
+-    try_modtypes env subst mty1 mty2
++    try_modtypes env cxt subst mty1 mty2
+   with
+     Dont_match ->
+-      raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
++      raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
+   | Error reasons ->
+-      raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
++      raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
++                  :: reasons))
+ 
+-and try_modtypes env subst mty1 mty2 =
++and try_modtypes env cxt subst mty1 mty2 =
+   match (mty1, mty2) with
+     (_, Tmty_ident p2) ->
+-      try_modtypes2 env mty1 (Subst.modtype subst mty2)
++      try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
+   | (Tmty_ident p1, _) ->
+-      try_modtypes env subst (expand_module_path env p1) mty2
++      try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
+   | (Tmty_signature sig1, Tmty_signature sig2) ->
+-      signatures env subst sig1 sig2
++      signatures env cxt subst sig1 sig2
+   | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
+       let arg2' = Subst.modtype subst arg2 in
+-      let cc_arg = modtypes env Subst.identity arg2' arg1 in
++      let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
+       let cc_res =
+-        modtypes (Env.add_module param1 arg2' env)
++        modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
+           (Subst.add_module param2 (Pident param1) subst) res1 res2 in
+       begin match (cc_arg, cc_res) with
+           (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
+@@ -158,19 +164,19 @@
+   | (_, _) ->
+       raise Dont_match
+ 
+-and try_modtypes2 env mty1 mty2 =
++and try_modtypes2 env cxt mty1 mty2 =
+   (* mty2 is an identifier *)
+   match (mty1, mty2) with
+     (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
+       Tcoerce_none
+   | (_, Tmty_ident p2) ->
+-      try_modtypes env Subst.identity mty1 (expand_module_path env p2)
++      try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
+   | (_, _) ->
+       assert false
+ 
+ (* Inclusion between signatures *)
+ 
+-and signatures env subst sig1 sig2 =
++and signatures env cxt subst sig1 sig2 =
+   (* Environment used to check inclusion of components *)
+   let new_env =
+     Env.add_signature sig1 env in
+@@ -202,7 +208,7 @@
+   let rec pair_components subst paired unpaired = function
+       [] ->
+         begin match unpaired with
+-            [] -> signature_components new_env subst (List.rev paired)
++            [] -> signature_components new_env cxt subst (List.rev paired)
+           | _  -> raise(Error unpaired)
+         end
+     | item2 :: rem ->
+@@ -234,7 +240,7 @@
+             ((item1, item2, pos1) :: paired) unpaired rem
+         with Not_found ->
+           let unpaired =
+-            if report then Missing_field id2 :: unpaired else unpaired in
++            if report then (cxt, Missing_field id2) :: unpaired else unpaired in
+           pair_components subst paired unpaired rem
+         end in
+   (* Do the pairing and checking, and return the final coercion *)
+@@ -242,65 +248,67 @@
+ 
+ (* Inclusion between signature components *)
+ 
+-and signature_components env subst = function
++and signature_components env cxt subst = function
+     [] -> []
+   | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
+-      let cc = value_descriptions env subst id1 valdecl1 valdecl2 in
++      let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
+       begin match valdecl2.val_kind with
+-        Val_prim p -> signature_components env subst rem
+-      | _ -> (pos, cc) :: signature_components env subst rem
++        Val_prim p -> signature_components env cxt subst rem
++      | _ -> (pos, cc) :: signature_components env cxt subst rem
+       end
+   | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
+-      type_declarations env subst id1 tydecl1 tydecl2;
+-      signature_components env subst rem
++      type_declarations env cxt subst id1 tydecl1 tydecl2;
++      signature_components env cxt subst rem
+   | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
+     :: rem ->
+-      exception_declarations env subst id1 excdecl1 excdecl2;
+-      (pos, Tcoerce_none) :: signature_components env subst rem
++      exception_declarations env cxt subst id1 excdecl1 excdecl2;
++      (pos, Tcoerce_none) :: signature_components env cxt subst rem
+   | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
+       let cc =
+-        modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
+-      (pos, cc) :: signature_components env subst rem
++        modtypes env (Module id1::cxt) subst
++          (Mtype.strengthen env mty1 (Pident id1)) mty2 in
++      (pos, cc) :: signature_components env cxt subst rem
+   | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
+-      modtype_infos env subst id1 info1 info2;
+-      signature_components env subst rem
++      modtype_infos env cxt subst id1 info1 info2;
++      signature_components env cxt subst rem
+   | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
+-      class_declarations env subst id1 decl1 decl2;
+-      (pos, Tcoerce_none) :: signature_components env subst rem
++      class_declarations env cxt subst id1 decl1 decl2;
++      (pos, Tcoerce_none) :: signature_components env cxt subst rem
+   | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
+-      class_type_declarations env subst id1 info1 info2;
+-      signature_components env subst rem
++      class_type_declarations env cxt subst id1 info1 info2;
++      signature_components env cxt subst rem
+   | _ ->
+       assert false
+ 
+ (* Inclusion between module type specifications *)
+ 
+-and modtype_infos env subst id info1 info2 =
++and modtype_infos env cxt subst id info1 info2 =
+   let info2 = Subst.modtype_declaration subst info2 in
++  let cxt' = Modtype id :: cxt in
+   try
+     match (info1, info2) with
+       (Tmodtype_abstract, Tmodtype_abstract) -> ()
+     | (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
+     | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
+-        check_modtype_equiv env mty1 mty2
++        check_modtype_equiv env cxt' mty1 mty2
+     | (Tmodtype_abstract, Tmodtype_manifest mty2) ->
+-        check_modtype_equiv env (Tmty_ident(Pident id)) mty2
++        check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2
+   with Error reasons ->
+-    raise(Error(Modtype_infos(id, info1, info2) :: reasons))
++    raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
+ 
+-and check_modtype_equiv env mty1 mty2 =
++and check_modtype_equiv env cxt mty1 mty2 =
+   match
+-    (modtypes env Subst.identity mty1 mty2,
+-     modtypes env Subst.identity mty2 mty1)
++    (modtypes env cxt Subst.identity mty1 mty2,
++     modtypes env cxt Subst.identity mty2 mty1)
+   with
+     (Tcoerce_none, Tcoerce_none) -> ()
+-  | (_, _) -> raise(Error [Modtype_permutation])
++  | (_, _) -> raise(Error [cxt, Modtype_permutation])
+ 
+ (* Simplified inclusion check between module types (for Env) *)
+ 
+ let check_modtype_inclusion env mty1 path1 mty2 =
+   try
+-    ignore(modtypes env Subst.identity
++    ignore(modtypes env [] Subst.identity
+                     (Mtype.strengthen env mty1 path1) mty2)
+   with Error reasons ->
+     raise Not_found
+@@ -312,16 +320,16 @@
+ 
+ let compunit impl_name impl_sig intf_name intf_sig =
+   try
+-    signatures Env.initial Subst.identity impl_sig intf_sig
++    signatures Env.initial [] Subst.identity impl_sig intf_sig
+   with Error reasons ->
+-    raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
++    raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
+ 
+-(* Hide the substitution parameter to the outside world *)
++(* Hide the context and substitution parameters to the outside world *)
+ 
+-let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2
+-let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2
++let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
++let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
+ let type_declarations env id decl1 decl2 =
+-  type_declarations env Subst.identity id decl1 decl2
++  type_declarations env [] Subst.identity id decl1 decl2
+ 
+ (* Error report *)
+ 
+@@ -384,9 +392,62 @@
+   | Unbound_modtype_path path ->
+       fprintf ppf "Unbound module type %a" Printtyp.path path
+ 
+-let report_error ppf = function
+-  |  [] -> ()
+-  | err :: errs ->
+-      let print_errs ppf errs =
+-         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
+-      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
++let rec context ppf = function
++    Module id :: rem ->
++      fprintf ppf "@[<2>module %a%a@]" ident id args rem
++  | Modtype id :: rem ->
++      fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
++  | Body x :: rem ->
++      fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem
++  | Arg x :: rem ->
++      fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
++  | [] ->
++      fprintf ppf "<here>"
++and context_mty ppf = function
++    (Module _ | Modtype _) :: _ as rem ->
++      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
++  | cxt -> context ppf cxt
++and args ppf = function
++    Body x :: rem ->
++      fprintf ppf "(%a)%a" ident x args rem
++  | Arg x :: rem ->
++      fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
++  | cxt ->
++      fprintf ppf " :@ %a" context_mty cxt
++
++let path_of_context = function
++    Module id :: rem ->
++      let rec subm path = function
++          [] -> path
++        | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
++        | _ -> assert false
++      in subm (Pident id) rem
++  | _ -> assert false
++
++let context ppf cxt =
++  if cxt = [] then () else
++  if List.for_all (function Module _ -> true | _ -> false) cxt then
++    fprintf ppf "In module %a:@ " path (path_of_context cxt)
++  else
++    fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
++
++let include_err ppf (cxt, err) =
++  fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err
++
++let max_size = 500
++let buffer = String.create max_size
++let is_big obj =
++  try ignore (Marshal.to_buffer buffer 0 max_size obj []); false
++  with _ -> true
++
++let report_error ppf errs =
++  if errs = [] then () else
++  let (errs , err) = split_last errs in
++  let pe = ref true in
++  let include_err' ppf err =
++    if !Clflags.show_trace || not (is_big err) then
++      fprintf ppf "%a@ " include_err err
++    else if !pe then (fprintf ppf "...@ "; pe := false)
++  in
++  let print_errs ppf = List.iter (include_err' ppf) in
++  fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err
+Index: typing/includemod.mli
+===================================================================
+--- typing/includemod.mli      (revision 11161)
++++ typing/includemod.mli      (working copy)
+@@ -24,7 +24,7 @@
+ val type_declarations:
+       Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
+ 
+-type error =
++type symptom =
+     Missing_field of Ident.t
+   | Value_descriptions of Ident.t * value_description * value_description
+   | Type_declarations of Ident.t * type_declaration
+@@ -43,6 +43,10 @@
+       Ctype.class_match_failure list
+   | Unbound_modtype_path of Path.t
+ 
++type pos =
++    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
++type error = pos list * symptom
++
+ exception Error of error list
+ 
+ val report_error: formatter -> error list -> unit
+Index: utils/clflags.ml
+===================================================================
+--- utils/clflags.ml   (revision 11161)
++++ utils/clflags.ml   (working copy)
+@@ -53,6 +53,7 @@
+ and dllpaths = ref ([] : string list)   (* -dllpath *)
+ and make_package = ref false            (* -pack *)
+ and for_package = ref (None: string option) (* -for-pack *)
++and show_trace = ref false              (* -show-trace *)
+ let dump_parsetree = ref false          (* -dparsetree *)
+ and dump_rawlambda = ref false          (* -drawlambda *)
+ and dump_lambda = ref false             (* -dlambda *)
+Index: utils/clflags.mli
+===================================================================
+--- utils/clflags.mli  (revision 11161)
++++ utils/clflags.mli  (working copy)
+@@ -50,6 +50,7 @@
+ val dllpaths : string list ref
+ val make_package : bool ref
+ val for_package : string option ref
++val show_trace : bool ref
+ val dump_parsetree : bool ref
+ val dump_rawlambda : bool ref
+ val dump_lambda : bool ref

diff --git a/experimental/garrigue/multimatch.diffs b/experimental/garrigue/multimatch.diffs
new file mode 100644 (file)
index 0000000..6eb34b7
--- /dev/null
+++ b/experimental/garrigue/multimatch.diffs
@@ -0,0 +1,1418 @@
+Index: parsing/lexer.mll
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/lexer.mll,v
+retrieving revision 1.73
+diff -u -r1.73 lexer.mll
+--- parsing/lexer.mll  11 Apr 2005 16:44:26 -0000      1.73
++++ parsing/lexer.mll  2 Feb 2006 06:28:32 -0000
+@@ -63,6 +63,8 @@
+     "match", MATCH;
+     "method", METHOD;
+     "module", MODULE;
++    "multifun", MULTIFUN;
++    "multimatch", MULTIMATCH;
+     "mutable", MUTABLE;
+     "new", NEW;
+     "object", OBJECT;
+Index: parsing/parser.mly
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
+retrieving revision 1.123
+diff -u -r1.123 parser.mly
+--- parsing/parser.mly 23 Mar 2005 03:08:37 -0000      1.123
++++ parsing/parser.mly 2 Feb 2006 06:28:32 -0000
+@@ -257,6 +257,8 @@
+ %token MINUSDOT
+ %token MINUSGREATER
+ %token MODULE
++%token MULTIFUN
++%token MULTIMATCH
+ %token MUTABLE
+ %token <nativeint> NATIVEINT
+ %token NEW
+@@ -325,7 +327,7 @@
+ %nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
+ %nonassoc LET                           /* above SEMI ( ...; let ... in ...) */
+ %nonassoc below_WITH
+-%nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
++%nonassoc FUNCTION WITH MULTIFUN        /* below BAR  (match ... with ...) */
+ %nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
+ %nonassoc THEN                          /* below ELSE (if ... then ...) */
+ %nonassoc ELSE                          /* (if ... then ... else ...) */
+@@ -804,8 +806,12 @@
+       { mkexp(Pexp_function("", None, List.rev $3)) }
+   | FUN labeled_simple_pattern fun_def
+       { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
++  | MULTIFUN opt_bar match_cases
++      { mkexp(Pexp_multifun(List.rev $3)) }
+   | MATCH seq_expr WITH opt_bar match_cases
+-      { mkexp(Pexp_match($2, List.rev $5)) }
++      { mkexp(Pexp_match($2, List.rev $5, false)) }
++  | MULTIMATCH seq_expr WITH opt_bar match_cases
++      { mkexp(Pexp_match($2, List.rev $5, true)) }
+   | TRY seq_expr WITH opt_bar match_cases
+       { mkexp(Pexp_try($2, List.rev $5)) }
+   | TRY seq_expr WITH error
+@@ -1318,10 +1324,10 @@
+   | simple_core_type2                           { Rinherit $1 }
+ ;
+ tag_field:
+-    name_tag OF opt_ampersand amper_type_list
+-      { Rtag ($1, $3, List.rev $4) }
+-  | name_tag
+-      { Rtag ($1, true, []) }
++    name_tag OF opt_ampersand amper_type_list amper_type_pair_list
++      { Rtag ($1, $3, List.rev $4, $5) }
++  | name_tag amper_type_pair_list
++      { Rtag ($1, true, [], $2) }
+ ;
+ opt_ampersand:
+     AMPERSAND                                   { true }
+@@ -1331,6 +1337,11 @@
+     core_type                                   { [$1] }
+   | amper_type_list AMPERSAND core_type         { $3 :: $1 }
+ ;
++amper_type_pair_list:
++    AMPERSAND core_type EQUAL core_type amper_type_pair_list
++      { ($2, $4) :: $5 }
++  | /* empty */
++      { [] }
+ opt_present:
+     LBRACKETGREATER name_tag_list RBRACKET      { List.rev $2 }
+   | /* empty */                                 { [] }
+Index: parsing/parsetree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
+retrieving revision 1.42
+diff -u -r1.42 parsetree.mli
+--- parsing/parsetree.mli      23 Mar 2005 03:08:37 -0000      1.42
++++ parsing/parsetree.mli      2 Feb 2006 06:28:32 -0000
+@@ -43,7 +43,7 @@
+   | Pfield_var
+ 
+ and row_field =
+-    Rtag of label * bool * core_type list
++    Rtag of label * bool * core_type list * (core_type * core_type) list
+   | Rinherit of core_type
+ 
+ (* XXX Type expressions for the class language *)
+@@ -86,7 +86,7 @@
+   | Pexp_let of rec_flag * (pattern * expression) list * expression
+   | Pexp_function of label * expression option * (pattern * expression) list
+   | Pexp_apply of expression * (label * expression) list
+-  | Pexp_match of expression * (pattern * expression) list
++  | Pexp_match of expression * (pattern * expression) list * bool
+   | Pexp_try of expression * (pattern * expression) list
+   | Pexp_tuple of expression list
+   | Pexp_construct of Longident.t * expression option * bool
+@@ -111,6 +111,7 @@
+   | Pexp_lazy of expression
+   | Pexp_poly of expression * core_type option
+   | Pexp_object of class_structure
++  | Pexp_multifun of (pattern * expression) list
+ 
+ (* Value descriptions *)
+ 
+Index: parsing/printast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
+retrieving revision 1.29
+diff -u -r1.29 printast.ml
+--- parsing/printast.ml        4 Jan 2006 16:55:50 -0000       1.29
++++ parsing/printast.ml        2 Feb 2006 06:28:32 -0000
+@@ -205,10 +205,14 @@
+       line i ppf "Pexp_apply\n";
+       expression i ppf e;
+       list i label_x_expression ppf l;
+-  | Pexp_match (e, l) ->
++  | Pexp_match (e, l, b) ->
+       line i ppf "Pexp_match\n";
+       expression i ppf e;
+       list i pattern_x_expression_case ppf l;
++      bool i ppf b
++  | Pexp_multifun l ->
++      line i ppf "Pexp_multifun\n";
++      list i pattern_x_expression_case ppf l;
+   | Pexp_try (e, l) ->
+       line i ppf "Pexp_try\n";
+       expression i ppf e;
+@@ -653,7 +657,7 @@
+ 
+ and label_x_bool_x_core_type_list i ppf x =
+   match x with
+-    Rtag (l, b, ctl) ->
++    Rtag (l, b, ctl, cstr) ->
+       line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
+       list (i+1) core_type ppf ctl
+   | Rinherit (ct) ->
+Index: typing/btype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
+retrieving revision 1.38
+diff -u -r1.38 btype.ml
+--- typing/btype.ml    4 Jan 2006 16:55:50 -0000       1.38
++++ typing/btype.ml    2 Feb 2006 06:28:32 -0000
+@@ -66,16 +66,16 @@
+     Clink r when !r <> Cunknown -> commu_repr !r
+   | c -> c
+ 
+-let rec row_field_repr_aux tl = function
+-    Reither(_, tl', _, {contents = Some fi}) ->
+-      row_field_repr_aux (tl@tl') fi
+-  | Reither(c, tl', m, r) ->
+-      Reither(c, tl@tl', m, r)
++let rec row_field_repr_aux tl tl2 = function
++    Reither(_, tl', _, tl2', {contents = Some fi}) ->
++      row_field_repr_aux (tl@tl') (tl2@tl2') fi
++  | Reither(c, tl', m, tl2', r) ->
++      Reither(c, tl@tl', m, tl2@tl2', r)
+   | Rpresent (Some _) when tl <> [] ->
+       Rpresent (Some (List.hd tl))
+   | fi -> fi
+ 
+-let row_field_repr fi = row_field_repr_aux [] fi
++let row_field_repr fi = row_field_repr_aux [] [] fi
+ 
+ let rec rev_concat l ll =
+   match ll with
+@@ -170,7 +170,8 @@
+     (fun (_, fi) ->
+       match row_field_repr fi with
+       | Rpresent(Some ty) -> f ty
+-      | Reither(_, tl, _, _) -> List.iter f tl
++      | Reither(_, tl, _, tl2, _) ->
++          List.iter f tl; List.iter (fun (t1,t2) -> f t1; f t2) tl2
+       | _ -> ())
+     row.row_fields;
+   match (repr row.row_more).desc with
+@@ -208,15 +209,17 @@
+       (fun (l, fi) -> l,
+         match row_field_repr fi with
+         | Rpresent(Some ty) -> Rpresent(Some(f ty))
+-        | Reither(c, tl, m, e) ->
++        | Reither(c, tl, m, tpl, e) ->
+             let e = if keep then e else ref None in
+             let m = if row.row_fixed then fixed else m in
+             let tl = List.map f tl in
++            let tl1 = List.map (fun (t1,_) -> repr (f t1)) tpl
++            and tl2 = List.map (fun (_,t2) -> repr (f t2)) tpl in
+             bound := List.filter
+                 (function {desc=Tconstr(_,[],_)} -> false | _ -> true)
+-                (List.map repr tl)
++                (List.map repr tl @ tl1 @ tl2)
+               @ !bound;
+-            Reither(c, tl, m, e)
++            Reither(c, tl, m, List.combine tl1 tl2, e)
+         | _ -> fi)
+       row.row_fields in
+   let name =
+Index: typing/ctype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
+retrieving revision 1.200
+diff -u -r1.200 ctype.ml
+--- typing/ctype.ml    6 Jan 2006 02:16:24 -0000       1.200
++++ typing/ctype.ml    2 Feb 2006 06:28:32 -0000
+@@ -340,7 +340,7 @@
+       let fi = filter_row_fields erase fi in
+       match row_field_repr f with
+         Rabsent -> fi
+-      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
++      | Reither(_,_,false,_,e) when erase -> set_row_field e Rabsent; fi
+       | _ -> p :: fi
+ 
+                     (**************************************)
+@@ -1286,6 +1286,10 @@
+ 
+ module TypeMap = Map.Make (TypeOps)
+ 
++
++(* A list of univars which may appear free in a type, but only if generic *)
++let allowed_univars = ref TypeSet.empty
++
+ (* Test the occurence of free univars in a type *)
+ (* that's way too expansive. Must do some kind of cacheing *)
+ let occur_univar env ty =
+@@ -1307,7 +1311,12 @@
+     then
+       match ty.desc with
+         Tunivar ->
+-          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
++          if TypeSet.mem ty bound then () else
++          if TypeSet.mem ty !allowed_univars &&
++            (ty.level = generic_level ||
++             ty.level = pivot_level - generic_level)
++          then ()
++          else raise (Unify [ty, newgenvar()])
+       | Tpoly (ty, tyl) ->
+           let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
+           occur_rec bound  ty
+@@ -1393,6 +1402,7 @@
+   with exn -> univar_pairs := old_univars; raise exn
+ 
+ let univar_pairs = ref []
++let delayed_conditionals = ref []
+ 
+ 
+                               (*****************)
+@@ -1691,9 +1701,11 @@
+               with Not_found -> (h,l)::hl)
+             (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields)
+             (List.map fst r2));
++  let fixed1 = row1.row_fixed || rm1.desc <> Tvar
++  and fixed2 = row2.row_fixed || rm2.desc <> Tvar in
+   let more =
+-    if row1.row_fixed then rm1 else
+-    if row2.row_fixed then rm2 else
++    if fixed1 then rm1 else
++    if fixed2 then rm2 else
+     newgenvar ()
+   in update_level env (min rm1.level rm2.level) more;
+   let fixed = row1.row_fixed || row2.row_fixed
+@@ -1726,18 +1738,18 @@
+   let bound = row1.row_bound @ row2.row_bound in
+   let row0 = {row_fields = []; row_more = more; row_bound = bound;
+               row_closed = closed; row_fixed = fixed; row_name = name} in
+-  let set_more row rest =
++  let set_more row row_fixed rest =
+     let rest =
+       if closed then
+         filter_row_fields row.row_closed rest
+       else rest in
+-    if rest <> [] && (row.row_closed || row.row_fixed)
+-    || closed && row.row_fixed && not row.row_closed then begin
++    if rest <> [] && (row.row_closed || row_fixed)
++    || closed && row_fixed && not row.row_closed then begin
+       let t1 = mkvariant [] true and t2 = mkvariant rest false in
+       raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
+     end;
+     let rm = row_more row in
+-    if row.row_fixed then
++    if row_fixed then
+       if row0.row_more == rm then () else
+       if rm.desc = Tvar then link_type rm row0.row_more else
+       unify env rm row0.row_more
+@@ -1748,11 +1760,11 @@
+   in
+   let md1 = rm1.desc and md2 = rm2.desc in
+   begin try
+-    set_more row1 r2;
+-    set_more row2 r1;
++    set_more row1 fixed1 r2;
++    set_more row2 fixed2 r1;
+     List.iter
+       (fun (l,f1,f2) ->
+-        try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2
++        try unify_row_field env fixed1 fixed2 row1 row2 l f1 f2
+         with Unify trace ->
+           raise (Unify ((mkvariant [l,f1] true,
+                          mkvariant [l,f2] true) :: trace)))
+@@ -1761,13 +1773,13 @@
+     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
+   end
+ 
+-and unify_row_field env fixed1 fixed2 l f1 f2 =
++and unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 =
+   let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
+   if f1 == f2 then () else
+   match f1, f2 with
+     Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
+   | Rpresent None, Rpresent None -> ()
+-  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
++  | Reither(c1, tl1, m1, tp1, e1), Reither(c2, tl2, m2, tp2, e2) ->
+       if e1 == e2 then () else
+       let redo =
+         (m1 || m2) &&
+@@ -1777,32 +1789,70 @@
+             List.iter (unify env t1) tl;
+             !e1 <> None || !e2 <> None
+         end in
+-      if redo then unify_row_field env fixed1 fixed2 l f1 f2 else
++      let redo =
++        redo || begin
++          if tp1 = [] && fixed1 then unify_pairs env tp2;
++          if tp2 = [] && fixed2 then unify_pairs env tp1;
++          !e1 <> None || !e2 <> None
++        end
++      in
++      if redo then unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 else
+       let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+       let rec remq tl = function [] -> []
+         | ty :: tl' ->
+             if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
+       in
+       let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
++      let repr_pairs = List.map (fun (t1,t2) -> repr t1, repr t2) in
++      let tp1 = repr_pairs tp1 and tp2 = repr_pairs tp2 in
++      let rec rempq tp = function [] -> []
++        | (t1,t2 as p) :: tp' ->
++            if List.exists (fun (t1',t2') -> t1==t1' && t2==t2') (tp@tp') then
++              rempq tp tp'
++            else p :: rempq tp tp'
++      in
++      let tp1' =
++        if fixed2 then begin
++          delayed_conditionals :=
++            (!univar_pairs, tp1, l, row2) :: !delayed_conditionals;
++          []
++        end else rempq tp2 tp1
++      and tp2' =
++        if fixed1 then begin
++          delayed_conditionals :=
++            (!univar_pairs, tp2, l, row1) :: !delayed_conditionals;
++          []
++        end else rempq tp1 tp2
++      in
+       let e = ref None in
+-      let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
+-      and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
+-      set_row_field e1 f1'; set_row_field e2 f2';
+-  | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2
+-  | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1
++      let f1' = Reither(c1 || c2, tl1', m1 || m2, tp2', e)
++      and f2' = Reither(c1 || c2, tl2', m1 || m2, tp1', e) in
++      set_row_field e1 f1'; set_row_field e2 f2'
++  | Reither(_, _, false, _, e1), Rabsent -> set_row_field e1 f2
++  | Rabsent, Reither(_, _, false, _, e2) -> set_row_field e2 f1
+   | Rabsent, Rabsent -> ()
+-  | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
++  | Reither(false, tl, _, tp, e1), Rpresent(Some t2) when not fixed1 ->
+       set_row_field e1 f2;
+-      (try List.iter (fun t1 -> unify env t1 t2) tl
++      begin try
++        List.iter (fun t1 -> unify env t1 t2) tl;
++        List.iter (fun (t1,t2) -> unify env t1 t2) tp
++      with exn -> e1 := None; raise exn
++      end
++  | Rpresent(Some t1), Reither(false, tl, _, tp, e2) when not fixed2 ->
++      set_row_field e2 f1;
++      begin try
++        List.iter (unify env t1) tl;
++        List.iter (fun (t1,t2) -> unify env t1 t2) tp
++      with exn -> e2 := None; raise exn
++      end
++  | Reither(true, [], _, tpl, e1), Rpresent None when not fixed1 ->
++      set_row_field e1 f2;
++      (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
+       with exn -> e1 := None; raise exn)
+-  | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
++  | Rpresent None, Reither(true, [], _, tpl, e2) when not fixed2 ->
+       set_row_field e2 f1;
+-      (try List.iter (unify env t1) tl
++      (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
+       with exn -> e2 := None; raise exn)
+-  | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
+-      set_row_field e1 f2
+-  | Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
+-      set_row_field e2 f1
+   | _ -> raise (Unify [])
+     
+ 
+@@ -1920,6 +1970,166 @@
+                         (*  Matching between type schemes  *)
+                         (***********************************)
+ 
++(* Forward declaration (order should be reversed...) *)
++let equal' = ref (fun _ -> failwith "Ctype.equal'")
++
++let make_generics_univars tyl =
++  let polyvars = ref TypeSet.empty in
++  let rec make_rec ty =
++    let ty = repr ty in
++    if ty.level = generic_level then begin
++      if ty.desc = Tvar  then begin
++        log_type ty;
++        ty.desc <- Tunivar;
++        polyvars := TypeSet.add ty !polyvars
++      end
++      else if ty.desc = Tunivar then set_level ty (generic_level - 1);
++      ty.level <- pivot_level - generic_level;
++      iter_type_expr make_rec ty
++    end
++  in
++  List.iter make_rec tyl;
++  List.iter unmark_type tyl;
++  !polyvars
++
++(* New version of moregeneral, using unification *)
++
++let copy_cond (p,tpl,l,row) =
++  let row =
++    match repr (copy (newgenty (Tvariant row))) with
++      {desc=Tvariant row} -> row
++    | _ -> assert false
++  and pairs =
++    List.map (fun (t1,t2) -> copy t1, copy t2) tpl in
++  (p, pairs, l, row)
++
++let get_row_field l row =
++  try row_field_repr (List.assoc l (row_repr row).row_fields)
++  with Not_found -> Rabsent
++
++let rec check_conditional_list env cdtls pattvars tpls =
++  match cdtls with
++    [] ->
++      let finished =
++        List.for_all (fun (_,t1,t2) -> !equal' env false [t1] [t2]) tpls in
++      if not finished then begin
++        let polyvars = make_generics_univars pattvars in
++        delayed_conditionals := [];
++        allowed_univars := polyvars;
++        List.iter (fun (pairs, ty1, ty2) -> unify_pairs env ty1 ty2 pairs)
++          tpls;
++        check_conditionals env polyvars !delayed_conditionals
++      end
++  | (pairs, tpl1, l, row2 as cond) :: cdtls ->
++      let cont = check_conditional_list env cdtls pattvars in
++      let tpl1 =
++        List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
++      let included =
++        List.for_all
++          (fun (t1,t2) ->
++            List.exists
++              (fun (_,t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
++              tpls)
++          tpl1 in
++      if included then cont tpls else
++      match get_row_field l row2 with
++        Rpresent _ ->
++          cont (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
++      | Rabsent -> cont tpls
++      | Reither (c, tl2, _, _, _) ->
++          cont tpls;
++          if c && tl2 <> [] then () (* cannot succeed *) else
++          let (pairs, tpl1, l, row2) = copy_cond cond
++          and tpls = List.map (fun (p,t1,t2) -> p, copy t1, copy t2) tpls
++          and pattvars = List.map copy pattvars
++          and cdtls = List.map copy_cond cdtls in
++          cleanup_types ();
++          let tl2, tpl2, e2 =
++            match get_row_field l row2 with
++              Reither (c, tl2, _, tpl2, e2) -> tl2, tpl2, e2
++            | _ -> assert false
++          in
++          let snap = Btype.snapshot () in
++          let ok =
++            try
++              begin match tl2 with
++                [] ->
++                  set_row_field e2 (Rpresent None)
++              | t::tl ->
++                  set_row_field e2 (Rpresent (Some t));
++                  List.iter (unify env t) tl
++              end;
++              List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
++              true
++            with exn ->
++              Btype.backtrack snap;
++              false
++          in
++            (* This is not [cont] : types have been copied *)
++          if ok then
++            check_conditional_list env cdtls pattvars
++              (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
++
++and check_conditionals env polyvars cdtls =
++  let cdtls = List.map copy_cond cdtls in
++  let pattvars = ref [] in
++  TypeSet.iter
++    (fun ty ->
++      let ty = repr ty in
++      match ty.desc with
++        Tsubst ty ->
++          let ty = repr ty in
++          begin match ty.desc with
++            Tunivar ->
++              log_type ty;
++              ty.desc <- Tvar;
++              pattvars := ty :: !pattvars
++          | Ttuple [tv;_] ->
++              if tv.desc = Tunivar then
++                (log_type tv; tv.desc <- Tvar; pattvars := ty :: !pattvars)
++              else if tv.desc <> Tvar then assert false
++          | Tvar -> ()
++          | _ -> assert false
++          end
++      | _ -> ())
++    polyvars;
++  cleanup_types ();
++  check_conditional_list env cdtls !pattvars []
++  
++
++(* Must empty univar_pairs first *)
++let unify_poly env polyvars subj patt =
++  let old_level = !current_level in
++  current_level := generic_level;
++  delayed_conditionals := [];
++  allowed_univars := polyvars;
++  try
++    unify env subj patt;
++    check_conditionals env polyvars !delayed_conditionals;
++    current_level := old_level;
++    allowed_univars := TypeSet.empty;
++    delayed_conditionals := []
++  with exn ->
++    current_level := old_level;
++    allowed_univars := TypeSet.empty;
++    delayed_conditionals := [];
++    raise exn
++
++let moregeneral env _ subj patt =
++  let old_level = !current_level in
++  current_level := generic_level;
++  let subj = instance subj
++  and patt = instance patt in
++  let polyvars = make_generics_univars [patt] in
++  current_level := old_level;
++  let snap = Btype.snapshot () in
++  try
++    unify_poly env polyvars subj patt;
++    true
++  with Unify _ ->
++    Btype.backtrack snap;
++    false
++
+ (*
+    Update the level of [ty]. First check that the levels of generic
+    variables from the subject are not lowered.
+@@ -2072,35 +2282,101 @@
+         Rpresent(Some t1), Rpresent(Some t2) ->
+           moregen inst_nongen type_pairs env t1 t2
+       | Rpresent None, Rpresent None -> ()
+-      | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ ->
++      | Reither(false, tl1, _, [], e1), Rpresent(Some t2) when not univ ->
+           set_row_field e1 f2;
+           List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
+-      | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
++      | Reither(c1, tl1, _, tpl1, e1), Reither(c2, tl2, m2, tpl2, e2) ->
+           if e1 != e2 then begin
+             if c1 && not c2 then raise(Unify []);
+-            set_row_field e1 (Reither (c2, [], m2, e2));
+-            if List.length tl1 = List.length tl2 then
+-              List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
+-            else match tl2 with
+-              t2 :: _ ->
++            let tpl' = if tpl1 = [] then tpl2 else [] in
++            set_row_field e1 (Reither (c2, [], m2, tpl', e2));
++            begin match tl2 with
++              [t2] ->
+                 List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
+                   tl1
+-            | [] ->
+-                if tl1 <> [] then raise (Unify [])
++            | _ ->
++                if List.length tl1 <> List.length tl2 then raise (Unify []);
++                List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
++            end;
++            if tpl1 <> [] then
++              delayed_conditionals :=
++                (!univar_pairs, tpl1, l, row2) :: !delayed_conditionals
+           end
+-      | Reither(true, [], _, e1), Rpresent None when not univ ->
++      | Reither(true, [], _, [], e1), Rpresent None when not univ ->
+           set_row_field e1 f2
+-      | Reither(_, _, _, e1), Rabsent when not univ ->
++      | Reither(_, _, _, [], e1), Rabsent when not univ ->
+           set_row_field e1 f2
+       | Rabsent, Rabsent -> ()
+       | _ -> raise (Unify []))
+     pairs
+ 
++let check_conditional env (pairs, tpl1, l, row2) tpls cont =
++  let tpl1 =
++    List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
++  let included =
++    List.for_all
++      (fun (t1,t2) ->
++        List.exists (fun (t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
++          tpls)
++      tpl1 in
++  if tpl1 = [] || included then cont tpls else
++  match get_row_field l row2 with
++    Rpresent _ -> cont (tpl1 @ tpls)
++  | Rabsent -> cont tpls
++  | Reither (c, tl2, _, tpl2, e2) ->
++      if not c || tl2 = [] then begin
++        let snap = Btype.snapshot () in
++        let ok =
++          try
++            begin match tl2 with
++              [] ->
++                set_row_field e2 (Rpresent None)
++            | t::tl ->
++                set_row_field e2 (Rpresent (Some t));
++                List.iter (unify env t) tl
++            end;
++            List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
++            true
++          with Unify _ -> false
++        in
++        if ok then cont (tpl1 @ tpls);
++        Btype.backtrack snap
++      end;
++      cont tpls
++
++let rec check_conditionals inst_nongen env cdtls tpls =
++  match cdtls with
++    [] ->
++      let tpls =
++        List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpls in
++      if tpls = [] then () else begin
++        delayed_conditionals := [];
++        let tl1, tl2 = List.split tpls in
++        let type_pairs = TypePairs.create 13 in
++        List.iter2 (moregen false type_pairs env) tl2 tl1;
++        check_conditionals inst_nongen env !delayed_conditionals []
++      end
++  | cdtl :: cdtls ->
++      check_conditional env cdtl tpls
++        (check_conditionals inst_nongen env cdtls)
++
++
+ (* Must empty univar_pairs first *)
+ let moregen inst_nongen type_pairs env patt subj =
+   univar_pairs := [];
+-  moregen inst_nongen type_pairs env patt subj
++  delayed_conditionals := [];
++  try
++    moregen inst_nongen type_pairs env patt subj;
++    check_conditionals inst_nongen env !delayed_conditionals [];
++    univar_pairs := [];
++    delayed_conditionals := []
++  with exn ->
++    univar_pairs := [];
++    delayed_conditionals := [];
++    raise exn
++
+ 
++(* old implementation
+ (*
+    Non-generic variable can be instanciated only if [inst_nongen] is
+    true. So, [inst_nongen] should be set to false if the subject might
+@@ -2128,6 +2404,7 @@
+   in
+   current_level := old_level;
+   res
++*)
+ 
+ 
+ (* Alternative approach: "rigidify" a type scheme,
+@@ -2296,30 +2573,36 @@
+     {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+   | _ -> raise Cannot_expand
+   with Cannot_expand ->
++  let eqtype_rec = eqtype rename type_pairs subst env in
+   let row1 = row_repr row1 and row2 = row_repr row2 in
+   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+   if row1.row_closed <> row2.row_closed
+   || not row1.row_closed && (r1 <> [] || r2 <> [])
+   || filter_row_fields false (r1 @ r2) <> []
+   then raise (Unify []);
+-  if not (static_row row1) then
+-    eqtype rename type_pairs subst env row1.row_more row2.row_more;
++  if not (static_row row1) then eqtype_rec row1.row_more row2.row_more;
+   List.iter
+     (fun (_,f1,f2) ->
+       match row_field_repr f1, row_field_repr f2 with
+         Rpresent(Some t1), Rpresent(Some t2) ->
+-          eqtype rename type_pairs subst env t1 t2
+-      | Reither(true, [], _, _), Reither(true, [], _, _) ->
+-          ()
+-      | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) ->
+-          eqtype rename type_pairs subst env t1 t2;
++          eqtype_rec t1 t2
++      | Reither(true, [], _, tp1, _), Reither(true, [], _, tp2, _) ->
++          List.iter2
++            (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
++            tp1 tp2
++      | Reither(false, t1::tl1, _, tpl1, _),
++        Reither(false, t2::tl2, _, tpl2, _) ->
++          eqtype_rec t1 t2;
++          List.iter2
++            (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
++            tpl1 tpl2;
+           if List.length tl1 = List.length tl2 then
+             (* if same length allow different types (meaning?) *)
+-            List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
++            List.iter2 eqtype_rec tl1 tl2
+           else begin
+             (* otherwise everything must be equal *)
+-            List.iter (eqtype rename type_pairs subst env t1) tl2;
+-            List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
++            List.iter (eqtype_rec t1) tl2;
++            List.iter (fun t1 -> eqtype_rec t1 t2) tl1
+           end
+       | Rpresent None, Rpresent None -> ()
+       | Rabsent, Rabsent -> ()
+@@ -2334,6 +2617,8 @@
+   with
+     Unify _ -> false
+ 
++let () = equal' := equal
++
+ (* Must empty univar_pairs first *)  
+ let eqtype rename type_pairs subst env t1 t2 =
+   univar_pairs := [];
+@@ -2770,14 +3055,14 @@
+           (fun (l,f as orig) -> match row_field_repr f with
+             Rpresent None ->
+               if posi then
+-                (l, Reither(true, [], false, ref None)), Unchanged
++                (l, Reither(true, [], false, [], ref None)), Unchanged
+               else
+                 orig, Unchanged
+           | Rpresent(Some t) ->
+               let (t', c) = build_subtype env visited loops posi level' t in
+               if posi && level > 0 then begin
+                 bound := t' :: !bound;
+-                (l, Reither(false, [t'], false, ref None)), c
++                (l, Reither(false, [t'], false, [], ref None)), c
+               end else
+                 (l, Rpresent(Some t')), c
+           | _ -> assert false)
+@@ -2960,11 +3245,11 @@
+       List.fold_left
+         (fun cstrs (_,f1,f2) ->
+           match row_field_repr f1, row_field_repr f2 with
+-            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
++            (Rpresent None|Reither(true,_,_,[],_)), Rpresent None ->
+               cstrs
+           | Rpresent(Some t1), Rpresent(Some t2) ->
+               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+-          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
++          | Reither(false, t1::_, _, [], _), Rpresent(Some t2) ->
+               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+           | Rabsent, _ -> cstrs
+           | _ -> raise Exit)
+@@ -2977,11 +3262,11 @@
+         (fun cstrs (_,f1,f2) ->
+           match row_field_repr f1, row_field_repr f2 with
+             Rpresent None, Rpresent None
+-          | Reither(true,[],_,_), Reither(true,[],_,_)
++          | Reither(true,[],_,[],_), Reither(true,[],_,[],_)
+           | Rabsent, Rabsent ->
+               cstrs
+           | Rpresent(Some t1), Rpresent(Some t2)
+-          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
++          | Reither(false,[t1],_,[],_), Reither(false,[t2],_,[],_) ->
+               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+           | _ -> raise Exit)
+         cstrs pairs
+@@ -3079,16 +3364,26 @@
+       let fields = List.map
+           (fun (l,f) ->
+             let f = row_field_repr f in l,
+-            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
+-              let tyl' =
+-                List.fold_left
+-                  (fun tyl ty ->
+-                    if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
+-                    then tyl else ty::tyl)
+-                  [ty] tyl
++            match f with Reither(b, tyl, m, tp, e) ->
++              let rem_dbl eq l =
++                List.rev
++                  (List.fold_left
++                     (fun xs x -> if List.exists (eq x) xs then xs else x::xs)
++                     [] l)
++              in
++              let tyl' = rem_dbl (fun t1 t2 -> equal env false [t1] [t2]) tyl
++              and tp' =
++                  List.filter
++                    (fun (ty1,ty2) -> not (equal env false [ty1] [ty2])) tp
++              in
++              let tp' =
++                rem_dbl
++                  (fun (t1,t2) (t1',t2') -> equal env false [t1;t2] [t1';t2'])
++                  tp'
+               in
+-              if List.length tyl' <= List.length tyl then
+-                let f = Reither(b, List.rev tyl', m, ref None) in
++              if List.length tyl' < List.length tyl
++              || List.length tp' < List.length tp then
++                let f = Reither(b, tyl', m, tp', ref None) in
+                 set_row_field e f;
+                 f
+               else f
+@@ -3344,9 +3639,9 @@
+       List.iter
+         (fun (l,fi) ->
+           match row_field_repr fi with
+-            Reither (c, t1::(_::_ as tl), m, e) ->
++            Reither (c, t1::(_::_ as tl), m, tp, e) ->
+               List.iter (unify env t1) tl;
+-              set_row_field e (Reither (c, [t1], m, ref None))
++              set_row_field e (Reither (c, [t1], m, tp, ref None))
+           | _ ->
+               ())
+         row.row_fields;
+Index: typing/includecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/includecore.ml,v
+retrieving revision 1.32
+diff -u -r1.32 includecore.ml
+--- typing/includecore.ml      8 Aug 2005 05:40:52 -0000       1.32
++++ typing/includecore.ml      2 Feb 2006 06:28:32 -0000
+@@ -71,10 +71,10 @@
+       (fun (_, f1, f2) ->
+         match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+           Rpresent(Some t1),
+-          (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
++          (Rpresent(Some t2) | Reither(false,[t2],_,[],_)) ->
+             to_equal := (t1,t2) :: !to_equal; true
+-        | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
+-        | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
++        | Rpresent None, (Rpresent None | Reither(true,[],_,[],_)) -> true
++        | Reither(c1,tl1,_,[],_), Reither(c2,tl2,_,[],_)
+           when List.length tl1 = List.length tl2 && c1 = c2 ->
+             to_equal := List.combine tl1 tl2 @ !to_equal; true
+         | Rabsent, (Reither _ | Rabsent) -> true
+Index: typing/oprint.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
+retrieving revision 1.22
+diff -u -r1.22 oprint.ml
+--- typing/oprint.ml   23 Mar 2005 03:08:37 -0000      1.22
++++ typing/oprint.ml   2 Feb 2006 06:28:33 -0000
+@@ -223,14 +223,18 @@
+       print_fields rest ppf []
+   | (s, t) :: l ->
+       fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
+-and print_row_field ppf (l, opt_amp, tyl) =
++and print_row_field ppf (l, opt_amp, tyl, tpl) =
+   let pr_of ppf =
+     if opt_amp then fprintf ppf " of@ &@ "
+     else if tyl <> [] then fprintf ppf " of@ "
+-    else fprintf ppf ""
+-  in
+-  fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
+-    tyl
++  and pr_tp ppf (t1,t2) =
++    fprintf ppf "@[<hv 2>%a =@ %a@]"
++      print_out_type t1
++      print_out_type t2
++  in
++  fprintf ppf "@[<hv 2>`%s%t%a%a@]" l pr_of
++    (print_typlist print_out_type " &") tyl
++    (print_list_init pr_tp (fun ppf -> fprintf ppf " &@ ")) tpl
+ and print_typlist print_elem sep ppf =
+   function
+     [] -> ()
+Index: typing/outcometree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
+retrieving revision 1.14
+diff -u -r1.14 outcometree.mli
+--- typing/outcometree.mli     23 Mar 2005 03:08:37 -0000      1.14
++++ typing/outcometree.mli     2 Feb 2006 06:28:33 -0000
+@@ -61,7 +61,8 @@
+       bool * out_variant * bool * (string list) option
+   | Otyp_poly of string list * out_type
+ and out_variant =
+-  | Ovar_fields of (string * bool * out_type list) list
++  | Ovar_fields of
++      (string * bool * out_type list * (out_type * out_type) list ) list
+   | Ovar_name of out_ident * out_type list
+ 
+ type out_class_type =
+Index: typing/parmatch.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/parmatch.ml,v
+retrieving revision 1.70
+diff -u -r1.70 parmatch.ml
+--- typing/parmatch.ml 24 Mar 2005 17:20:54 -0000      1.70
++++ typing/parmatch.ml 2 Feb 2006 06:28:33 -0000
+@@ -568,11 +568,11 @@
+     List.fold_left
+       (fun nm (tag,f) ->
+         match Btype.row_field_repr f with
+-        | Reither(_, _, false, e) ->
++        | Reither(_, _, false, _, e) ->
+             (* m=false means that this tag is not explicitly matched *)
+             Btype.set_row_field e Rabsent;
+             None
+-        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
++        | Rabsent | Reither (_, _, true, _, _) | Rpresent _ -> nm)
+       row.row_name row.row_fields in
+   if not row.row_closed || nm != row.row_name then begin
+     (* this unification cannot fail *)
+@@ -605,8 +605,8 @@
+       List.for_all
+         (fun (tag,f) ->
+           match Btype.row_field_repr f with
+-            Rabsent | Reither(_, _, false, _) -> true
+-          | Reither (_, _, true, _)
++            Rabsent | Reither(_, _, false, _, _) -> true
++          | Reither (_, _, true, _, _)
+               (* m=true, do not discard matched tags, rather warn *)
+           | Rpresent _ -> List.mem tag fields)
+         row.row_fields
+@@ -739,7 +739,7 @@
+           match Btype.row_field_repr f with
+             Rabsent (* | Reither _ *) -> others
+           (* This one is called after erasing pattern info *)
+-          | Reither (c, _, _, _) -> make_other_pat tag c :: others
++          | Reither (c, _, _, _, _) -> make_other_pat tag c :: others
+           | Rpresent arg -> make_other_pat tag (arg = None) :: others)
+         [] row.row_fields
+     with
+Index: typing/printtyp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
+retrieving revision 1.140
+diff -u -r1.140 printtyp.ml
+--- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000       1.140
++++ typing/printtyp.ml 2 Feb 2006 06:28:33 -0000
+@@ -157,9 +157,12 @@
+ and raw_field ppf = function
+     Rpresent None -> fprintf ppf "Rpresent None"
+   | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
+-  | Reither (c,tl,m,e) ->
+-      fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
+-        raw_type_list tl m
++  | Reither (c,tl,m,tpl,e) ->
++      fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,%a,@,@[<1>ref%t@])@]"
++        c raw_type_list tl m
++        (raw_list
++           (fun ppf (t1,t2) ->
++             fprintf ppf "@[%a,@,%a@]" raw_type t1 raw_type t2)) tpl
+         (fun ppf ->
+           match !e with None -> fprintf ppf " None"
+           | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
+@@ -219,8 +222,9 @@
+   List.for_all
+     (fun (_, f) ->
+        match row_field_repr f with
+-       | Reither(c, l, _, _) ->
+-           row.row_closed && if c then l = [] else List.length l = 1
++       | Reither(c, l, _, pl, _) ->
++           row.row_closed && pl = [] &&
++           if c then l = [] else List.length l = 1
+        | _ -> true)
+     row.row_fields
+ 
+@@ -392,13 +396,16 @@
+ 
+ and tree_of_row_field sch (l, f) =
+   match row_field_repr f with
+-  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
+-  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
+-  | Reither(c, tyl, _, _) ->
+-      if c (* contradiction: un constructeur constant qui a un argument *)
+-      then (l, true, tree_of_typlist sch tyl)
+-      else (l, false, tree_of_typlist sch tyl)
+-  | Rabsent -> (l, false, [] (* une erreur, en fait *))
++  | Rpresent None | Reither(true, [], _, [], _) -> (l, false, [], [])
++  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty], [])
++  | Reither(c, tyl, _, tpl, _) ->
++      let ttpl =
++        List.map
++          (fun (t1,t2) -> tree_of_typexp sch t1, tree_of_typexp sch t2)
++          tpl
++      in
++      (l, c && tpl = [], tree_of_typlist sch tyl, ttpl)
++  | Rabsent -> (l, false, [], [] (* une erreur, en fait *))
+ 
+ and tree_of_typlist sch tyl =
+   List.map (tree_of_typexp sch) tyl
+Index: typing/typeclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
+retrieving revision 1.85
+diff -u -r1.85 typeclass.ml
+--- typing/typeclass.ml        22 Jul 2005 06:42:36 -0000      1.85
++++ typing/typeclass.ml        2 Feb 2006 06:28:33 -0000
+@@ -727,7 +727,7 @@
+         {pexp_loc = loc; pexp_desc =
+          Pexp_match({pexp_loc = loc; pexp_desc =
+                      Pexp_ident(Longident.Lident"*opt*")},
+-                    scases)} in
++                    scases, false)} in
+       let sfun =
+         {pcl_loc = scl.pcl_loc; pcl_desc =
+          Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
+Index: typing/typecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
+retrieving revision 1.178
+diff -u -r1.178 typecore.ml
+--- typing/typecore.ml 6 Jan 2006 02:25:37 -0000       1.178
++++ typing/typecore.ml 2 Feb 2006 06:28:33 -0000
+@@ -156,15 +156,21 @@
+       let field = row_field tag row in
+       begin match field with
+       | Rabsent -> assert false
+-      | Reither (true, [], _, e) when not row.row_closed ->
+-          set_row_field e (Rpresent None)
+-      | Reither (false, ty::tl, _, e) when not row.row_closed ->
++      | Reither (true, [], _, tpl, e) when not row.row_closed ->
++          set_row_field e (Rpresent None);
++          List.iter
++            (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
++            tpl
++      | Reither (false, ty::tl, _, tpl, e) when not row.row_closed ->
+           set_row_field e (Rpresent (Some ty));
++          List.iter
++            (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
++            tpl;
+           begin match opat with None -> assert false
+           | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
+           end
+-      | Reither (c, l, true, e) when not row.row_fixed ->
+-          set_row_field e (Reither (c, [], false, ref None))
++      | Reither (c, l, true, tpl, e) when not row.row_fixed ->
++          set_row_field e (Reither (c, [], false, [], ref None))
+       | _ -> ()
+       end;
+       (* Force check of well-formedness *)
+@@ -307,13 +313,13 @@
+         match row_field_repr f with
+           Rpresent None ->
+             (l,None) :: pats,
+-            (l, Reither(true,[], true, ref None)) :: fields
++            (l, Reither(true,[], true, [], ref None)) :: fields
+         | Rpresent (Some ty) ->
+             bound := ty :: !bound;
+             (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+                       pat_type=ty})
+             :: pats,
+-            (l, Reither(false, [ty], true, ref None)) :: fields
++            (l, Reither(false, [ty], true, [], ref None)) :: fields
+         | _ -> pats, fields)
+       ([],[]) fields in
+   let row =
+@@ -337,6 +343,18 @@
+           pat pats in
+       rp { r with pat_loc = loc }
+ 
++let rec flatten_or_pat pat =
++  match pat.pat_desc with
++    Tpat_or (p1, p2, _) ->
++      flatten_or_pat p1 @ flatten_or_pat p2
++  | _ ->
++      [pat]
++
++let all_variants pat =
++  List.for_all
++    (function {pat_desc=Tpat_variant _} -> true | _ -> false)
++    (flatten_or_pat pat)
++
+ let rec find_record_qual = function
+   | [] -> None
+   | (Longident.Ldot (modname, _), _) :: _ -> Some modname
+@@ -423,7 +441,7 @@
+       let arg = may_map (type_pat env) sarg in
+       let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
+       let row = { row_fields =
+-                    [l, Reither(arg = None, arg_type, true, ref None)];
++                    [l, Reither(arg = None, arg_type, true, [], ref None)];
+                   row_bound = arg_type;
+                   row_closed = false;
+                   row_more = newvar ();
+@@ -788,7 +806,7 @@
+        newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
+   | Pexp_function (p,_,(_,e)::_) ->
+        newty (Tarrow(p, newvar (), type_approx env e, Cok))
+-  | Pexp_match (_, (_,e)::_) -> type_approx env e
++  | Pexp_match (_, (_,e)::_, false) -> type_approx env e
+   | Pexp_try (e, _) -> type_approx env e
+   | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
+   | Pexp_ifthenelse (_,e,_) -> type_approx env e
+@@ -939,17 +957,26 @@
+         exp_loc = sexp.pexp_loc;
+         exp_type = ty_res;
+         exp_env = env }
+-  | Pexp_match(sarg, caselist) ->
++  | Pexp_match(sarg, caselist, multi) ->
+       let arg = type_exp env sarg in
+       let ty_res = newvar() in
+       let cases, partial =
+-        type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist
++        type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi
+       in
+       re {
+         exp_desc = Texp_match(arg, cases, partial);
+         exp_loc = sexp.pexp_loc;
+         exp_type = ty_res;
+         exp_env = env }
++  | Pexp_multifun caselist ->
++      let ty_arg = newvar() and ty_res = newvar() in
++      let cases, partial =
++        type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist ~multi:true
++      in
++      { exp_desc = Texp_function (cases, partial);
++        exp_loc = sexp.pexp_loc;
++        exp_type = newty (Tarrow ("", ty_arg, ty_res, Cok));
++        exp_env = env }
+   | Pexp_try(sbody, caselist) ->
+       let body = type_exp env sbody in
+       let cases, _ =
+@@ -1758,7 +1785,7 @@
+         {pexp_loc = loc; pexp_desc =
+          Pexp_match({pexp_loc = loc; pexp_desc =
+                      Pexp_ident(Longident.Lident"*opt*")},
+-                    scases)} in
++                    scases, false)} in
+       let sfun =
+         {pexp_loc = sexp.pexp_loc; pexp_desc =
+          Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
+@@ -1864,7 +1891,8 @@
+ 
+ (* Typing of match cases *)
+ 
+-and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
++and type_cases ?in_function ?(multi=false)
++    env ty_arg ty_res partial_loc caselist =
+   let ty_arg' = newvar () in
+   let pattern_force = ref [] in
+   let pat_env_list =
+@@ -1898,10 +1926,64 @@
+   let cases =
+     List.map2
+       (fun (pat, ext_env) (spat, sexp) ->
+-        let exp = type_expect ?in_function ext_env sexp ty_res in
+-        (pat, exp))
+-      pat_env_list caselist
+-  in
++        let add_variant_case lab row ty_res ty_res' =
++          let fi = List.assoc lab (row_repr row).row_fields in
++          begin match row_field_repr fi with
++            Reither (c, _, m, _, e) ->
++              let row' =
++                { row_fields =
++                  [lab, Reither(c,[],false,[ty_res,ty_res'], ref None)];
++                  row_more = newvar (); row_bound = [ty_res; ty_res'];
++                  row_closed = false; row_fixed = false; row_name = None }
++              in
++              unify_pat ext_env {pat with pat_type= newty (Tvariant row)}
++                (newty (Tvariant row'))
++          | _ ->
++              unify_exp ext_env
++                { exp_desc = Texp_tuple []; exp_type = ty_res;
++                  exp_env = ext_env; exp_loc = sexp.pexp_loc }
++                ty_res'
++          end
++        in
++        pat,
++        match pat.pat_desc with
++          _ when multi && all_variants pat ->
++            let ty_res' = newvar () in
++            List.iter
++              (function {pat_desc=Tpat_variant(lab,_,row)} ->
++                add_variant_case lab row ty_res ty_res'
++              | _ -> assert false)
++              (flatten_or_pat pat);
++            type_expect ?in_function ext_env sexp ty_res'
++        | Tpat_alias (p, id) when multi && all_variants p ->
++            let vd = Env.find_value (Path.Pident id) ext_env in
++            let row' =
++              match repr vd.val_type with
++                {desc=Tvariant row'} -> row'
++              | _ -> assert false
++            in
++            begin_def ();
++            let tv = newvar () in
++            let env = Env.add_value id {vd with val_type=tv} ext_env in
++            let exp = type_exp env sexp in
++            end_def ();
++            generalize exp.exp_type;
++            generalize tv;
++            List.iter
++              (function {pat_desc=Tpat_variant(lab,_,row)}, [tv'; ty'] ->
++                let fi' = List.assoc lab (row_repr row').row_fields in
++                let row' =
++                  {row' with row_fields=[lab,fi']; row_more=newvar()} in
++                unify_pat ext_env {pat with pat_type=tv'}
++                  (newty (Tvariant row'));
++                add_variant_case lab row ty_res ty'
++              | _ -> assert false)
++              (List.map (fun p -> p, instance_list [tv; exp.exp_type])
++                 (flatten_or_pat p));
++            {exp with exp_type = instance exp.exp_type}
++        | _ ->
++            type_expect ?in_function ext_env sexp ty_res)
++      pat_env_list caselist in
+   let partial =
+     match partial_loc with None -> Partial
+     | Some loc -> Parmatch.check_partial loc cases
+Index: typing/typedecl.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typedecl.ml,v
+retrieving revision 1.75
+diff -u -r1.75 typedecl.ml
+--- typing/typedecl.ml 16 Aug 2005 00:48:56 -0000      1.75
++++ typing/typedecl.ml 2 Feb 2006 06:28:33 -0000
+@@ -432,8 +432,10 @@
+               match Btype.row_field_repr f with
+                 Rpresent (Some ty) ->
+                   compute_same ty
+-              | Reither (_, tyl, _, _) ->
+-                  List.iter compute_same tyl
++              | Reither (_, tyl, _, tpl, _) ->
++                  List.iter compute_same tyl;
++                  List.iter (compute_variance_rec true true true)
++                    (List.map fst tpl @ List.map snd tpl)
+               | _ -> ())
+             row.row_fields;
+           compute_same row.row_more
+@@ -856,8 +858,8 @@
+               explain row.row_fields
+                 (fun (l,f) -> match Btype.row_field_repr f with
+                   Rpresent (Some t) -> t
+-                | Reither (_,[t],_,_) -> t
+-                | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
++                | Reither (_,[t],_,_,_) -> t
++                | Reither (_,tl,_,_,_) -> Btype.newgenty (Ttuple tl)
+                 | _ -> Btype.newgenty (Ttuple[]))
+                 "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
+           | _ -> trivial ty'
+Index: typing/types.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
+retrieving revision 1.25
+diff -u -r1.25 types.ml
+--- typing/types.ml    9 Dec 2004 12:40:53 -0000       1.25
++++ typing/types.ml    2 Feb 2006 06:28:33 -0000
+@@ -48,7 +48,9 @@
+ 
+ and row_field =
+     Rpresent of type_expr option
+-  | Reither of bool * type_expr list * bool * row_field option ref
++  | Reither of
++      bool * type_expr list * bool *
++      (type_expr * type_expr) list * row_field option ref
+   | Rabsent
+ 
+ and abbrev_memo =
+Index: typing/types.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
+retrieving revision 1.25
+diff -u -r1.25 types.mli
+--- typing/types.mli   9 Dec 2004 12:40:53 -0000       1.25
++++ typing/types.mli   2 Feb 2006 06:28:33 -0000
+@@ -47,7 +47,9 @@
+ 
+ and row_field =
+     Rpresent of type_expr option
+-  | Reither of bool * type_expr list * bool * row_field option ref
++  | Reither of
++      bool * type_expr list * bool *
++      (type_expr * type_expr) list * row_field option ref
+         (* 1st true denotes a constant constructor *)
+         (* 2nd true denotes a tag in a pattern matching, and
+            is erased later *)
+Index: typing/typetexp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
+retrieving revision 1.54
+diff -u -r1.54 typetexp.ml
+--- typing/typetexp.ml 22 Jul 2005 06:42:36 -0000      1.54
++++ typing/typetexp.ml 2 Feb 2006 06:28:33 -0000
+@@ -207,9 +207,9 @@
+                 match Btype.row_field_repr f with
+                 | Rpresent (Some ty) ->
+                     bound := ty :: !bound;
+-                    Reither(false, [ty], false, ref None)
++                    Reither(false, [ty], false, [], ref None)
+                 | Rpresent None ->
+-                    Reither (true, [], false, ref None)
++                    Reither (true, [], false, [], ref None)
+                 | _ -> f)
+               row.row_fields
+           in
+@@ -273,13 +273,16 @@
+           (l, f) :: fields
+       in
+       let rec add_field fields = function
+-          Rtag (l, c, stl) ->
++          Rtag (l, c, stl, stpl) ->
+             name := None;
+             let f = match present with
+               Some present when not (List.mem l present) ->
+-                let tl = List.map (transl_type env policy) stl in
+-                bound := tl @ !bound;
+-                Reither(c, tl, false, ref None)
++                let transl_list = List.map (transl_type env policy) in
++                let tl = transl_list stl in
++                let stpl1, stpl2 = List.split stpl in
++                let tpl1 = transl_list stpl1 and tpl2 = transl_list stpl2 in
++                bound := tl @ tpl1 @ tpl2 @ !bound;
++                Reither(c, tl, false, List.combine tpl1 tpl2, ref None)
+             | _ ->
+                 if List.length stl > 1 || c && stl <> [] then
+                   raise(Error(styp.ptyp_loc, Present_has_conjunction l));
+@@ -311,9 +314,9 @@
+                     begin match f with
+                       Rpresent(Some ty) ->
+                         bound := ty :: !bound;
+-                        Reither(false, [ty], false, ref None)
++                        Reither(false, [ty], false, [], ref None)
+                     | Rpresent None ->
+-                        Reither(true, [], false, ref None)
++                        Reither(true, [], false, [], ref None)
+                     | _ ->
+                         assert false
+                     end
+@@ -406,7 +409,8 @@
+               {row with row_fixed=true;
+                row_fields = List.map
+                  (fun (s,f as p) -> match Btype.row_field_repr f with
+-                   Reither (c, tl, m, r) -> s, Reither (c, tl, true, r)
++                   Reither (c, tl, m, tpl, r) ->
++                     s, Reither (c, tl, true, tpl, r)
+                  | _ -> p)
+                  row.row_fields};
+         Btype.iter_row make_fixed_univars row
+Index: typing/unused_var.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
+retrieving revision 1.5
+diff -u -r1.5 unused_var.ml
+--- typing/unused_var.ml       4 Jan 2006 16:55:50 -0000       1.5
++++ typing/unused_var.ml       2 Feb 2006 06:28:33 -0000
+@@ -122,9 +122,11 @@
+   | Pexp_apply (e, lel) ->
+       expression ppf tbl e;
+       List.iter (fun (_, e) -> expression ppf tbl e) lel;
+-  | Pexp_match (e, pel) ->
++  | Pexp_match (e, pel, _) ->
+       expression ppf tbl e;
+       match_pel ppf tbl pel;
++  | Pexp_multifun pel ->
++      match_pel ppf tbl pel;
+   | Pexp_try (e, pel) ->
+       expression ppf tbl e;
+       match_pel ppf tbl pel;
+Index: bytecomp/matching.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/matching.ml,v
+retrieving revision 1.67
+diff -u -r1.67 matching.ml
+--- bytecomp/matching.ml       7 Sep 2005 16:07:48 -0000       1.67
++++ bytecomp/matching.ml       2 Feb 2006 06:28:33 -0000
+@@ -1991,7 +1991,7 @@
+     List.iter
+       (fun (_, f) ->
+         match Btype.row_field_repr f with
+-          Rabsent | Reither(true, _::_, _, _) -> ()
++          Rabsent | Reither(true, _::_, _, _, _) -> ()
+         | _ -> incr num_constr)
+       row.row_fields
+   else
+Index: toplevel/genprintval.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/toplevel/genprintval.ml,v
+retrieving revision 1.38
+diff -u -r1.38 genprintval.ml
+--- toplevel/genprintval.ml    13 Jun 2005 04:55:53 -0000      1.38
++++ toplevel/genprintval.ml    2 Feb 2006 06:28:33 -0000
+@@ -293,7 +293,7 @@
+                   | (l, f) :: fields ->
+                       if Btype.hash_variant l = tag then
+                         match Btype.row_field_repr f with
+-                        | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
++                        | Rpresent(Some ty) | Reither(_,[ty],_,_,_) ->
+                             let args =
+                               tree_of_val (depth - 1) (O.field obj 1) ty in
+                             Oval_variant (l, Some args)

diff --git a/experimental/garrigue/multimatch.ml b/experimental/garrigue/multimatch.ml
new file mode 100644 (file)
index 0000000..7c9aa73
--- /dev/null
+++ b/experimental/garrigue/multimatch.ml
@@ -0,0 +1,158 @@
+(* Simple example *)
+let f x =
+  (multimatch x with `A -> 1 | `B -> true),
+  (multimatch x with `A -> 1. | `B -> "1");;
+
+(* OK *)
+module M : sig
+  val f :
+    [< `A & 'a = int & 'b = float | `B &   'b =string & 'a =  bool] -> 'a * 'b
+end = struct let f = f end;;
+
+(* Bad *)
+module M : sig
+  val f :
+    [< `A & 'a = int & 'b = float | `B &   'b =string & 'a =   int] -> 'a * 'b
+end = struct let f = f end;;
+
+(* Should be good! *)
+module M : sig
+  val f :
+    [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
+end = struct let f = f end;;
+
+let f = multifun `A|`B as x -> f x;;
+
+(* Two-level example *)
+let f = multifun
+    `A -> (multifun `C -> 1 | `D -> 1.)
+  | `B -> (multifun `C -> true | `D -> "1");;
+
+(* OK *)
+module M : sig
+  val f :
+    [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
+     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
+end = struct let f = f end;;
+
+(* Bad *)
+module M : sig
+  val f :
+    [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
+     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
+end = struct let f = f end;;
+
+module M : sig
+  val f :
+    [< `A & 'b = [< `C & 'a = int | `D] -> 'a
+     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
+end = struct let f = f end;;
+
+
+(* Examples with hidden sharing *)
+let r = ref []
+let f = multifun `A -> 1 | `B -> true
+let g x = r := [f x];;
+
+(* Bad! *)
+module M : sig
+  val g : [< `A & 'a = int | `B & 'a = bool] -> unit
+end = struct let g = g end;;
+
+let r = ref []
+let f = multifun `A -> r | `B -> ref [];;
+(* Now OK *)
+module M : sig
+  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
+end = struct let f = f end;;
+(* Still OK *)
+let l : int list ref = r;;
+module M : sig
+  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
+end = struct let f = f end;;
+
+
+(* Examples that would need unification *)
+let f = multifun `A -> (1, []) | `B -> (true, [])
+let g x = fst (f x);;
+(* Didn't work, now Ok *)
+module M : sig
+  val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
+end = struct let g = g end;;
+let g = multifun (`A|`B) as x -> g x;;
+
+(* Other examples *)
+
+let f x =
+  let a = multimatch x with `A -> 1 | `B -> "1" in
+  (multifun `A -> print_int | `B -> print_string) x a
+;;
+
+let f = multifun (`A|`B) as x -> f x;;
+
+type unit_op = [`Set of int | `Move of int]
+type int_op = [`Get]
+
+let op r =
+  multifun
+    `Get     -> !r
+  | `Set x   -> r := x
+  | `Move dx -> r := !r + dx
+;;
+
+let rec trace r = function
+    [] -> []
+  | op1 :: ops ->
+      multimatch op1 with
+        #int_op as op1 ->
+          let x = op r op1 in
+          x :: trace r ops
+      | #unit_op as op1 ->
+          op r op1;
+          trace r ops
+;;
+
+class point x = object
+  val mutable x : int = x
+  method get = x
+  method set y = x <- y
+  method move dx = x <- x + dx
+end;;
+
+let poly sort coeffs x =
+  let add, mul, zero =
+    multimatch sort with
+      `Int -> (+), ( * ), 0
+    | `Float -> (+.), ( *. ), 0.
+  in
+  let rec compute = function
+      []     -> zero
+    | c :: cs -> add c (mul x (compute cs))
+  in
+  compute coeffs
+;;
+
+module M : sig
+  val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
+end = struct let poly = poly end;;
+
+type ('a,'b) num_sort =
+  'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
+module M : sig
+  val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
+end = struct let poly = poly end;;
+
+
+(* type dispatch *)
+
+type num = [ `Int | `Float ]
+let print0 = multifun
+    `Int -> print_int
+  | `Float -> print_float
+;;
+let print1 = multifun
+    #num as x -> print0 x
+  | `List t -> List.iter (print0 t)
+  | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
+;;
+print1 (`Pair(`Int,`Float)) (1,1.0);;

diff --git a/experimental/garrigue/newlabels.ps b/experimental/garrigue/newlabels.ps
new file mode 100644 (file)
index 0000000..01eac19
--- /dev/null
+++ b/experimental/garrigue/newlabels.ps
@@ -0,0 +1,1458 @@
+%!PS-Adobe-2.0
+%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp)
+%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com)
+%%Title: newlabels.dvi
+%%Pages: 2 0
+%%PageOrder: Ascend
+%%BoundingBox: 0 0 596 842
+%%EndComments
+%%BeginProcSet: PStoPS 1 15
+userdict begin
+[/showpage/erasepage/copypage]{dup where{pop dup load
+ type/operatortype eq{1 array cvx dup 0 3 index cvx put
+ bind def}{pop}ifelse}{pop}ifelse}forall
+[/letter/legal/executivepage/a4/a4small/b5/com10envelope
+ /monarchenvelope/c5envelope/dlenvelope/lettersmall/note
+ /folio/quarto/a5]{dup where{dup wcheck{exch{}put}
+ {pop{}def}ifelse}{pop}ifelse}forall
+/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put}
+ {pop def}ifelse}{def}ifelse
+/PStoPSmatrix matrix currentmatrix def
+/PStoPSxform matrix def/PStoPSclip{clippath}def
+/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def
+/initmatrix{matrix defaultmatrix setmatrix}bind def
+/initclip[{matrix currentmatrix PStoPSmatrix setmatrix
+ [{currentpoint}stopped{$error/newerror false put{newpath}}
+ {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse]
+ {[/newpath cvx{/moveto cvx}{/lineto cvx}
+ {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop}
+ stopped{$error/errorname get/invalidaccess eq{cleartomark
+ $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop
+ /initclip dup load dup type dup/operatortype eq{pop exch pop}
+ {dup/arraytype eq exch/packedarraytype eq or
+  {dup xcheck{exch pop aload pop}{pop cvx}ifelse}
+  {pop cvx}ifelse}ifelse
+ {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def
+/initgraphics{initmatrix newpath initclip 1 setlinewidth
+ 0 setlinecap 0 setlinejoin []0 setdash 0 setgray
+ 10 setmiterlimit}bind def
+end
+%%EndProcSet
+%DVIPSCommandLine: dvips -f newlabels
+%DVIPSParameters: dpi=300
+%DVIPSSource:  TeX output 1999.10.26:1616
+%%BeginProcSet: tex.pro
+%!
+/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
+/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
+mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
+ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
+isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
+hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
+TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
+forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
+/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
+/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
+/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
+string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
+end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
+/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
+N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
+length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
+128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
+get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
+dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
+/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
+/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
+0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
+setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
+.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
+if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
+length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
+cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
+0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
+add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
+/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
+known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
+/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn
+put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N
+/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley
+X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[
+(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup
+length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse}
+forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
+RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
+false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
+round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
+rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
+{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
+B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
+4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
+p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
+a}B /bos{/SS save N}B /eos{SS restore}B end
+
+%%EndProcSet
+TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi)
+@start
+%DVIPSBitmapFont: Fa cmr6 6 2
+/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49
+D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F
+8F0F> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fb cmmi8 8 4
+/Fb 4 111 df<FFC0FF1C00181C00101C00101C00103800203800203800203800207000
+40700040700040700040E00080E00080E00080E00080E00100E00200E004006008003830
+000FC00018177E9618> 85 D<0300038003000000000000000000000000001C00240046
+0046008C000C0018001800180031003100320032001C0009177F960C> 105
+D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06
+00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109
+D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818
+80300980300E00120E7F8D15> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fc cmbx8 8 4
+/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007
+800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C
+3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D<FC7E0FC0FD8730E03E07C0F03E07C0F03C
+0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F0FF
+1FE3FCFF1FE3FC1E0F7E8E23> 109 D<FC7C00FD8E003E0F003E0F003C0F003C0F003C0F
+003C0F003C0F003C0F003C0F003C0F003C0F00FF3FC0FF3FC0120F7E8E17> I
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fd cmsy8 8 3
+/Fd 3 93 df<FFFFF0FFFFF014027D881B> 0 D<020002000200C218F2783AE00F800F80
+3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0
+0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0
+006040002013137E9218> 92 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fe cmtt12 12 43
+/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF
+F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF
+F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35
+D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1
+FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C
+08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38
+D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0
+00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003
+C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0
+01C000E000E0007000700070003800380038003800380038003800380038003800700070
+007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0
+FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0
+01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0
+7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070
+F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00
+003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D
+9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001
+E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000
+38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F
+FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007
+FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E
+03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070
+03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F
+FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F
+C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A>
+I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I<
+0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000
+FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0
+0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000
+007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F
+C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000
+FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38
+01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000
+E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070
+1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D<FE03FEFF03FEFF03FE1D8070
+1D80701DC0701CC0701CC0701CE0701CE0701C60701C70701C70701C30701C38701C3870
+1C18701C1C701C1C701C0C701C0E701C0E701C06701C06701C07701C03701C0370FF81F0
+FF81F0FF80F0171E7F9D1A> 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0
+E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070
+000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E
+9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800
+003800003800003800003800003800003800003800003800003800003800003800003800
+00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I<FFFCFFFCFF
+FCE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E0
+00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFFCFFFCFF
+FC0E2776A21A> 91 D<FFFCFFFCFFFC001C001C001C001C001C001C001C001C001C001C
+001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C
+001C001C001C001C001CFFFCFFFCFFFC0E277FA21A> 93 D<1FF0003FFC007FFE00780F
+00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003
+80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00
+000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00
+380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
+C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070
+0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003
+FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0
+0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0
+E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A>
+I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF
+F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00
+07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000
+E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000
+E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000
+0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0
+0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC
+FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000
+0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000
+00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80
+121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108
+D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C
+001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
+007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F
+00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E
+00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0
+7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80
+1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00
+380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
+C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0
+007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003
+80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F
+FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F
+C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3
+F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0
+FFFFE0038000038000038000038000038000038000038000038000038000038000038070
+03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07
+E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
+E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E
+00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000
+EE0000EE0000EE00007C00007C0000380017157F941A> I<FF83FEFF83FEFF83FE380038
+3800381C00701C00701C00701C38701C7C701C7C700C6C600EEEE00EEEE00EEEE00EEEE0
+0EC6E006C6C007C7C00783C00783C017157F941A> I<7FC7F87FCFFC7FC7F80703C00383
+8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783
+C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007
+00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000
+6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F
+C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0
+F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Ff cmr8 8 3
+/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000
+003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000
+00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E
+000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49
+D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810
+183FF07FF0FFF00D157E9412> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fg cmmi12 12 13
+/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0
+0000C00000C00000C00001C0000180000180000380000380000380000700000300001615
+7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000
+004000000040000000800000008000000080000000800000010000000FE00000711C0001
+C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0
+080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001
+FE0000002000000020000000400000004000000040000000400000008000000080000000
+800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58
+D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000
+0300000300000600000600000600000C00000C00000C0000180000180000180000300000
+300000300000600000600000600000C00000C00000C00001800001800001800001800003
+00000300000300000600000600000600000C00000C00000C000018000018000018000030
+0000300000300000600000600000600000C00000C00000C0000011317DA418> 61
+D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00
+00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000
+0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000
+8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76
+D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780
+04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00
+00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800
+000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84
+D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000
+07800020000F000040000F000040000F000040000F000040001E000080001E000080001E
+000080001E000080003C000100003C000100003C000100003C0001000078000200007800
+020000780002000078000200007000040000F000040000F0000800007000080000700010
+00007000200000380040000038008000001C01000000060600000001F800000021237DA1
+21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000
+E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417>
+101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E
+001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C
+000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0
+0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E
+000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418
+> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00
+001C00001C00001C00001C000038000038000038000038000070000030000012157E9416
+> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038
+0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C
+> 120 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fh cmti12 12 22
+/Fh 22 122 df<FFF0FFF0FFE00C037C8B11> 45 D<70F8F8F0E005057A840F> I<00F8
+C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E
+00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97
+D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C
+0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010
+237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000
+780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B
+9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000
+E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807
+00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07
+8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000
+E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186
+000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00
+000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000
+00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000
+F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380
+700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07
+80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0
+003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E
+002300430043008700870087000E000E001C001C001C0038003800384070807080708071
+0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001
+C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E
+20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070
+3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380
+038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000
+700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047
+6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00
+E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380
+70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E
+40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038
+0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180
+0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780
+700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878
+0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380
+7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00
+001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087
+00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038
+000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C
+00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040
+08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF
+F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070
+8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030
+8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080
+1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119
+D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0
+0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E
+00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C
+03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060
+1C00F03800F03000E0600080C0004380003E0000141F7B9418> I
+E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fi cmbx12 12 20
+/Fi 20 122 df<FFFFFF8000FFFFFFF00007F003FC0007F0007E0007F0003F0007F0001F
+8007F0000FC007F00007E007F00007E007F00007F007F00003F007F00003F007F00003F0
+07F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807
+F00003F807F00003F807F00003F007F00003F007F00003F007F00007E007F00007E007F0
+000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF800025227E
+A12B> 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006
+FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F
+00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80
+18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003
+F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8
+00000003F800000003F800000003F800000003F800000003F800000003F800000003F800
+000003F800000003F800000003F800000003F800000003F800000003F800000003F80000
+0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022
+227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0
+03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F
+18167E951B> 97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000
+001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FE07C
+001F803E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000F
+C01F000FC01F000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF8
+00180FC0001A237EA21F> I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000
+FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060
+07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00
+F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0
+7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1
+E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0
+0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0
+0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780
+1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000
+0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00
+3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00
+0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000
+00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F00FFE0FFE00B247EA310> 105 D<FF00FF001F001F001F001F00
+1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
+1F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210> 108
+D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530> I<FF07E000
+FF1FF8001F307C001F403C001F803E001F803E001F003E001F003E001F003E001F003E00
+1F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00
+1F003E00FFE1FFC0FFE1FFC01A167E951F> I<00FE0007FFC00F83E01E00F03E00F87C00
+7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00
+F81F01F00F83E007FFC000FE0017167E951C> I<FF0FE000FF3FF8001FE07C001F803E00
+1F001F001F001F801F001F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC0
+1F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3FF8001F0FC000
+1F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FFE00000
+FFE000001A207E951F> I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F
+E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF
+FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007
+80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F
+80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000
+F80011207F9F16> I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E
+001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E
+001F003E001F007E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F> I<FFE07FC0
+FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000003F0000
+001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E00
+0E003E00FF80FFE0FF80FFE01B167F951E> 120 D<FFE01FE0FFE01FE01F8007000F8006
+000FC00E0007C00C0007E00C0003E0180003E0180001F0300001F0300000F8600000F860
+00007CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00
+00000C0000000C00000018000078180000FC380000FC300000FC60000069C000007F8000
+001F0000001B207F951E> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fj cmsy10 12 15
+/Fj 15 107 df<FFFFFFFCFFFFFFFC1E027C8C27> 0 D<03F0000FFC001FFE003FFF007F
+FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F
+FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000
+060000000C0000001800000030000000300000006000000060000000C0000000C0000000
+C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000
+30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A
+27> 26 D<00000001800000000001800000000001800000000001800000000000C00000
+000000C000000000006000000000003000000000003000000000001C00000000000E0000
+0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000
+000000300000000000300000000000600000000000C00000000000C00000000001800000
+00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003
+80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF
+FFFFC00000C000006000006000006000003000003000001800000C000006000003800001
+E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00
+00180000180000300000300000600000600000C00000C00000C000018000018000030000
+0300000600000600000C00000C0000180000180000300000300000600000600000C00000
+C0000180000180000300000300000300000600000600000C00000C000018000018000030
+0000300000600000600000C00000400000183079A300> 54 D<C0C0C0C0C0C0C0C0E0E0
+C0C0C0C0C0C0C0C003127D9400> I<00008000018001F980070F000C0300180380180780
+3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070
+E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0
+7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E
+A519> 59 D<000100000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000000300000003000000030000000300000003
+000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63
+D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
+C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
+C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006
+000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780
+78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000
+00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
+00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
+00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300
+0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030
+00030030000300300006001800060018000C000C000C000C000C000C0018000600180006
+003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94
+D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00
+00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E
+000003C012317DA419> 102 D<F800000F000003800001C00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E000007000003800001E000003C0001E0000380000700000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00001C0000380000F0000F8000012317DA419> I<C0C0C0C0C0C0C0C0C0C0C0C0C0
+C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
+02317AA40E> 106 D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fk cmr12 12 65
+/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007
+003800070038000700380007003800070038000700380007003800FFFFFFC00700380007
+003800070038000700380007003800070038000700380007003800070038000700380007
+0038000700380007003800070038000700380007003800070038000700380007003C007F
+E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800
+0700300007000000070000000700000007000000070000000700000007000000FFFFF800
+070078000700380007003800070038000700380007003800070038000700380007003800
+070038000700380007003800070038000700380007003800070038000700380007003800
+070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007
+0038000700380007003800070038000700380007003800070038000700380007003800FF
+FFF800070038000700380007003800070038000700380007003800070038000700380007
+003800070038000700380007003800070038000700380007003800070038000700380007
+003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E
+00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00
+0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0
+07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007
+001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700
+1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006
+0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000
+7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
+6000600060007000300030003000180018000C000C000400060003000100008000400020
+0B327CA413> I<800040002000100018000C000400060006000300030001800180018001
+C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
+C000C000C001C0018001800180030003000600060004000C00180010002000400080000B
+327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44
+D<FFF8FFF80D02808B10> I<70F8F8F87005057C840E> I<01F000071C000C0600180300
+3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0
+F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0
+3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003
+800380038003800380038003800380038003800380038003800380038003800380038003
+800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007
+002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003
+C0000780000700000E00001C0000180000300000600000C0000180000100000200200400
+200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020
+07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003
+F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0
+03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700
+000700000F00001700001700002700006700004700008700018700010700020700060700
+040700080700080700100700200700200700400700C00700FFFFF8000700000700000700
+000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000
+000000000070F8F8F87005157C940E> 58 D<FFFFFFFEFFFFFFFE000000000000000000
+0000000000000000000000000000000000000000000000FFFFFFFEFFFFFFFE1F0C7D9126
+> 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0
+00800080018001000100010001000100010000000000000000000000038007C007C007C0
+038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000
+05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000
+203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001
+000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E
+0001F8FF800FFF20237EA225> 65 D<FFFFF8000F800E0007800780078003C0078003E0
+078001E0078001F0078001F0078001F0078001F0078001F0078001E0078003E0078007C0
+07800F8007803E0007FFFE0007800780078003C0078001E0078001F0078000F0078000F8
+078000F8078000F8078000F8078000F8078000F8078001F0078001F0078003E0078007C0
+0F800F00FFFFFC001D227EA123> I<0007E0100038183000E0063001C00170038000F007
+0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8
+000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078
+0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001
+C0010000E0020000381C000007E0001C247DA223> I<FFFFF0000F801E00078007000780
+0380078001C0078000E0078000F007800078078000780780007C0780003C0780003C0780
+003C0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780
+003E0780003C0780003C0780007C0780007807800078078000F0078000E0078001E00780
+03C0078007000F801E00FFFFF0001F227EA125> I<FFFFFFC00F8007C0078001C0078000
+C00780004007800040078000600780002007800020078000200780202007802000078020
+0007802000078060000780E00007FFE0000780E000078060000780200007802000078020
+000780200007800000078000000780000007800000078000000780000007800000078000
+00078000000FC00000FFFE00001B227EA120> 70 D<0007F008003C0C1800E0021801C0
+01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800
+000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
+1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700
+0078038000B801C000B800E00318003C0C080007F00020247DA226> I<FFFC3FFF0FC003
+F0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
+E0078001E0078001E0078001E0078001E0078001E007FFFFE0078001E0078001E0078001
+E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
+E0078001E0078001E0078001E00FC003F0FFFC3FFF20227EA125> I<FFFC0FC007800780
+078007800780078007800780078007800780078007800780078007800780078007800780
+07800780078007800780078007800780078007800FC0FFFC0E227EA112> I<FFFC00FF80
+0FC0007C0007800030000780002000078000400007800080000780010000078002000007
+80040000078008000007801000000780200000078040000007808000000781C000000783
+E000000785E000000788F000000790F0000007A078000007C03C000007803C000007801E
+000007800F000007800F00000780078000078007C000078003C000078001E000078001E0
+00078000F000078000F8000FC000FC00FFFC07FF8021227EA126> 75
+D<FFFC001F80000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00
+000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00010F00
+010F00010F00010F00030F00030F00020F00060F00060F001E1F007EFFFFFE18227DA11E
+> I<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C
+0020041E0020041F0020040F002004078020040780200403C0200401E0200401E0200400
+F0200400F8200400782004003C2004003E2004001E2004000F2004000F20040007A00400
+03E0040003E0040001E0040001E0040000E00E0000601F000060FFE0002020227EA125>
+78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C
+0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8
+00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C
+0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000
+0FE0001F247DA226> I<FFFFF0000F803C0007800F0007800780078007C0078003C00780
+03E0078003E0078003E0078003E0078003E0078003E0078003C0078007C0078007800780
+0F0007803C0007FFF0000780000007800000078000000780000007800000078000000780
+0000078000000780000007800000078000000780000007800000078000000FC00000FFFC
+00001B227EA121> I<FFFFE000000F803C000007800E00000780078000078007C0000780
+03C000078003E000078003E000078003E000078003E000078003E000078003C000078007
+C000078007800007800E000007803C000007FFE000000780700000078038000007801C00
+0007801E000007800E000007800F000007800F000007800F000007800F000007800F8000
+07800F800007800F800007800F808007800FC080078007C0800FC003C100FFFC01E20000
+00007C0021237EA124> 82 D<03F0200C0C601802603001E07000E0600060E00060E000
+60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F
+C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000
+C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008
+4007800840078008C007800C800780048007800480078004800780040007800000078000
+000780000007800000078000000780000007800000078000000780000007800000078000
+000780000007800000078000000780000007800000078000000780000007800000078000
+00078000000FC00001FFFE001E227EA123> I<FFF0007FC01F80001F000F00000C000F80
+000C000780000800078000080003C000100003C000100003C000100001E000200001E000
+200001F000600000F000400000F000400000780080000078008000007C008000003C0100
+00003C010000001E020000001E020000001E020000000F040000000F040000000F8C0000
+000788000000078800000003D000000003D000000003F000000001E000000001E0000000
+00C000000000C000000000C0000022237FA125> 86 D<FFF03FFC03FE1F8007E000F80F
+0003C000700F0003C000200F0001E00020078001E00040078001E00040078003F0004003
+C002F0008003C002F0008003C002F0008003E00478018001E00478010001E00478010001
+E0083C010000F0083C020000F0083C020000F0101E02000078101E04000078101E040000
+78200F0400003C200F0800003C200F0800003C600F8800001E40079000001E4007900000
+1E4007D000001F8003F000000F8003E000000F8003E000000F0001E00000070001C00000
+070001C00000060000C0000002000080002F237FA132> I<FEFEC0C0C0C0C0C0C0C0C0C0
+C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FE
+FE07317BA40E> 91 D<FEFE060606060606060606060606060606060606060606060606
+060606060606060606060606060606060606060606FEFE07317FA40E> 93
+D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07
+00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97
+D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00
+1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723
+7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0
+0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94
+16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0
+F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE
+17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000
+00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315
+7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007
+0000070000070000070000FFF80007000007000007000007000007000007000007000007
+00000700000700000700000700000700000700000700000700000700000700000780007F
+F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780
+7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0
+0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00
+15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00
+700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00
+70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000
+000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
+000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000
+00000000007007F000F00070007000700070007000700070007000700070007000700070
+00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F>
+I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
+000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8
+000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723
+7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E
+000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
+00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E
+003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00
+3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038
+00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E
+00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E
+0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078
+F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700
+01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00
+1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F
+000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B
+> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0
+00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000
+00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F
+0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0
+10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80
+0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00
+1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04
+0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E
+00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006
+017003827800FC7F18157F941B> I<FF80FE1E00781E00300E00200E0020070040070040
+0780C003808003808001C10001C10000E20000E20000E200007400007400003800003800
+00380000100017157F941A> I<FF8FF87F3E01E03C1C01C0181C01E0180E01E0100E0260
+100E027010070270200704302007043820038438400388184003881C4001C81C8001D00C
+8001D00E8000F00F0000E0070000E00700006006000040020020157F9423> I<FF83FE1F
+00F00E00C007008007810003830001C20000E400007800007800003800003C00004E0000
+8F000187000103800201C00401E00C00E03E01F0FF03FE17157F941A> I<FF80FE1E0078
+1E00300E00200E00200700400700400780C003808003808001C10001C10000E20000E200
+00E200007400007400003800003800003800001000001000002000002000002000004000
+F04000F08000F180004300003C0000171F7F941A> I<3FFFC0380380300780200700600E
+00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00
+80380080780180700780FFFF8012157F9416> I<FFFFFFFFFFFF3001808C31> 124
+D E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fl cmbx12 14.4 19
+/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000
+FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007
+7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF
+00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80
+0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800
+003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8
+31> 67 D<FFFFFC0000FFFFFC0000FFFFFC000003FC00000003FC00000003FC00000003
+FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC
+00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00
+000003FC00000003FC00000003FC00000003FC0001C003FC0001C003FC0001C003FC0001
+C003FC0003C003FC00038003FC00038003FC00078003FC00078003FC000F8003FC000F80
+03FC001F8003FC007F8003FC01FF00FFFFFFFF00FFFFFFFF00FFFFFFFF0022297EA828>
+76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000
+03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000
+007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000
+003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000
+003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000
+007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800
+07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C
+A833> 79 D<FFFFF0007FFFFFFFF0007FFFFFFFF0007FFF03FE000001C001FE00000380
+01FE0000038001FF0000078000FF0000070000FF80000F00007F80000E00007FC0000E00
+003FC0001C00003FC0001C00003FE0003C00001FE0003800001FF0007800000FF0007000
+000FF80070000007F800E0000007F800E0000003FC01C0000003FC01C0000003FE03C000
+0001FE0380000001FF0780000000FF0700000000FF87000000007F8E000000007F8E0000
+00007FDE000000003FDC000000003FFC000000001FF8000000001FF8000000000FF00000
+00000FF0000000000FF00000000007E00000000007E00000000003C00000000003C00000
+30297FA833> 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F
+801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F
+803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F
+FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D<FFE00000FFE00000FFE000000FE000000FE0
+00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0
+00000FE000000FE1FE000FEFFF800FFE07E00FF803F00FF001F80FE000FC0FE000FC0FE0
+007E0FE0007E0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0
+007F0FE0007E0FE0007E0FE0007E0FE000FC0FE000FC0FF001F80FF803F00F9C0FE00F0F
+FF800E01FC00202A7EA925> I<00007FF000007FF000007FF0000007F0000007F0000007
+F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007
+F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007
+F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007
+F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87
+FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00
+0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00
+0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0
+1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07
+F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007
+F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007
+F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018
+2A7EA915> I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE0
+00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE07E000FE1
+FF800FE30FC00FE40FE00FE807E00FF807F00FF007F00FF007F00FE007F00FE007F00FE0
+07F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE0
+07F00FE007F00FE007F00FE007F00FE007F0FFFE3FFFFFFE3FFFFFFE3FFF202A7DA925>
+104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF
+E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F
+E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I<FFE0FFE0FFE00FE00FE00FE0
+0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0
+0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE
+0F2A7EA912> 108 D<FFC07E00FFC1FF80FFC30FC00FC40FE00FC807E00FD807F00FD007
+F00FD007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007
+F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F0FFFE3F
+FFFFFE3FFFFFFE3FFF201B7D9A25> 110 D<003FE00001FFFC0003F07E000FC01F801F80
+0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00
+03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80
+0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I<FFE1FE00FFEFFF80FFFE0F
+E00FF803F00FF001F80FE001FC0FE000FC0FE000FE0FE000FE0FE0007F0FE0007F0FE000
+7F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007E0FE000FE0FE000FE0FE000
+FC0FE001FC0FF001F80FF807F00FFC0FE00FEFFF800FE1FC000FE000000FE000000FE000
+000FE000000FE000000FE000000FE000000FE000000FE00000FFFE0000FFFE0000FFFE00
+0020277E9A25> I<FFC1F0FFC7FCFFC63E0FCC7F0FD87F0FD07F0FD07F0FF03E0FE0000F
+E0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000F
+E0000FE0000FE000FFFF00FFFF00FFFF00181B7F9A1B> 114 D<03FE300FFFF03E03F078
+00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800
+FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016
+1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000
+0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000
+0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070
+07F0E003F0C001FF80007F0014267FA51A> I<FFE07FF0FFE07FF0FFE07FF00FE007F00F
+E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00F
+E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE00FF00F
+E00FF007E017F003F067FF01FFC7FF007F87FF201B7D9A25> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fm cmr12 14.4 20
+/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44
+D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0
+0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
+0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
+0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001
+F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000
+F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0
+000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628
+7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C
+00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC
+001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C
+003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54
+D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800
+1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700
+9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00
+E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000
+1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80
+0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000
+0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000
+00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0
+3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000
+F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71
+D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003
+E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
+E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03
+C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74
+D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780
+07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E
+000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00
+00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000
+00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003
+C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000
+272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0
+000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0
+007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F
+8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00
+00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
+00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00
+01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00
+01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F
+C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000
+F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008
+1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00
+E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800
+007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101
+D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0
+007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00
+0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C
+0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E
+0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00
+1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00
+0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0
+0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E
+F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C
+1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300
+0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00
+F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00
+1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00
+00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99
+1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F
+00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F
+00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080
+E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0
+8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080
+000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780
+000780000780000780000780000780000780000780000780000780000780000780000780
+0007804007804007804007804007804007804007804003C08001C08000E100003E001225
+7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F
+000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
+000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F
+F01C1A7E9921> I E
+%EndDVIPSBitmapFont
+%DVIPSBitmapFont: Fn cmr17 20.74 18
+/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000
+03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8
+0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000
+000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000
+0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000
+0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000
+00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000
+FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F
+0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0
+00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000
+00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000
+01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00
+0000313D7CBB39> 67 D<FFFFFC000000FFFFFC00000003FE0000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
+F80000000001F80000000001F80000000001F80000006001F80000006001F80000006001
+F80000006001F80000006001F8000000E001F8000000C001F8000000C001F8000000C001
+F8000000C001F8000001C001F8000001C001F8000001C001F8000003C001F8000007C001
+F8000007C001F800000FC001F800003F8001F80000FF8003FC0007FF80FFFFFFFFFF80FF
+FFFFFFFF802B3B7CBA32> 76 D<000003FF00000000001E01E000000000F0003C000000
+03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8
+0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000
+00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000
+0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000
+01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001
+FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC
+FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F
+0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80
+00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000
+00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000
+01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0
+0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E
+00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0
+001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000
+01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E
+0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00
+0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97
+D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000
+03E000000003E000000003E000000003E000000003E000000003E000000003E000000003
+E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0
+00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800
+03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000
+7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E
+03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803
+E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383
+001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0
+03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000
+7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000
+FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018
+0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000
+3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E
+00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC
+000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F
+0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F
+257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0
+00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB
+18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000
+0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0
+000380000000000000000000000000000000000000000000000000000000000000000000
+0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
+7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF
+C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
+C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E
+01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00
+03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
+C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
+07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000
+FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003
+F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0
+0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000
+07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007
+C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF
+28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C
+000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0
+7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC
+000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00
+000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001
+C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003
+E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003
+E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
+E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
+E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114
+D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006
+00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0
+0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003
+80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070
+00807F800019257DA41F> I<003000000030000000300000003000000030000000300000
+0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000
+07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
+01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180
+01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400
+000E08000003F00019357FB41E> I<FFFE000FFFFFFE000FFF07F00007F803E00003E003
+E00001C001F00001C001F000018001F800018000F800030000F8000300007C000600007C
+000600007E000600003E000C00003E000C00003F001C00001F001800001F001800000F80
+3000000F803000000FC070000007C060000007C060000003E0C0000003E0C0000003F1C0
+000001F180000001F180000000FB00000000FB00000000FF000000007E000000007E0000
+00003C000000003C000000003C0000000018000028257FA42A> 118
+D E
+%EndDVIPSBitmapFont
+end
+%%EndProlog
+%%BeginSetup
+%%Feature: *Resolution 300dpi
+TeXDict begin
+%%PaperSize: a4
+
+userdict/PStoPSxform PStoPSmatrix matrix currentmatrix
+ matrix invertmatrix matrix concatmatrix
+ matrix invertmatrix put
+%%EndSetup
+%%Page: (0,1) 1
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 0.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+/showpage{}def/copypage{}def/erasepage{}def
+PStoPSxform concat
+1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p
+927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404
+370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719
+634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p
+Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p
+319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929
+a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101
+929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p
+Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073
+a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p
+259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687
+1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p
+1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360
+1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280
+a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459
+1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p
+878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m
+(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p
+1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p
+303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p
+681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p
+1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340
+a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p
+1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p
+322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk
+133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502
+a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p
+918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84
+1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p
+492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p
+891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p
+Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838
+a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594
+1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p
+991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301
+1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p
+Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg
+634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579
+2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004
+a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p
+Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p
+Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391
+2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p
+656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh
+634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p
+Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p
+Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p
+Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245
+a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245
+a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj
+579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305
+a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p
+Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p
+Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365
+a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p
+Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p
+Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365
+a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p
+Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p
+634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634
+2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182
+2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p
+Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634
+2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p
+Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p
+Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh
+956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop
+PStoPSsaved restore
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 421.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+PStoPSxform concat
+2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p
+Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141
+261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495
+261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p
+Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227
+366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p
+Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366
+a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366
+a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p
+Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p
+Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p
+Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427
+a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk
+790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p
+877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936
+434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010
+427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108
+427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185
+427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289
+427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427
+a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408
+427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p
+Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487
+a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p
+Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p
+Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p
+551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610
+494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671
+494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p
+Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p
+Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p
+Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p
+Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020
+547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p
+Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p
+Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p
+Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p
+Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547
+a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554
+a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p
+Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p
+Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607
+a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk
+451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p
+538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597
+614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p
+Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614
+a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417
+607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588
+607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p
+1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc
+1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579
+667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p
+Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p
+Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p
+945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk
+1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728
+a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246
+728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p
+Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p
+Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p
+555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk
+629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk
+698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p
+Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735
+a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999
+728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061
+728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p
+Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p
+Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728
+a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735
+a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p
+Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p
+Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788
+a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788
+a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p
+1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p
+Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p
+Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p
+Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848
+a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk
+470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p
+557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616
+855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688
+855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772
+855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848
+a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000
+848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060
+855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p
+Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p
+Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p
+Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848
+a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855
+a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p
+Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908
+a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi
+906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p
+Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p
+1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p
+Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p
+Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p
+240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p
+685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127
+a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127
+a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11
+1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187
+a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187
+a(original) p 764 1187 a(comfort) p 949 1187 a(of) p
+1009 1187 a(out-of-order) p 1283 1187 a(application) p
+1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814
+1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p
+431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p
+1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p
+1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626
+1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p
+Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308
+a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p
+Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p
+355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519
+1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p
+884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210
+1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p
+1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11
+1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605
+a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p
+728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p
+1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p
+1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605
+a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p
+184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p
+440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620
+1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184
+1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440
+1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839
+a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p
+363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568
+1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p
+927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p
+312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491
+1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p
+902 1960 a(=) p 953 1960 a(<fun>) 133 2020 y(val) p 235
+2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020
+a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020
+a(=) p 773 2020 a(<fun>) 133 2080 y(val) p 235 2080 a(f3) p
+312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491
+2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p
+927 2080 a(=) p 978 2080 a(<fun>) 133 2140 y(#) p 184
+2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140
+a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p
+722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184
+2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200
+a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a(<fun>) 133
+2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260
+a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p
+645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321
+a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p
+543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p
+850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p
+1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p
+1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p
+261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p
+204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555
+a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555
+a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138
+2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462
+2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555
+a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p
+Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615
+a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270
+2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p
+547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p
+850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p
+1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515
+2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11
+2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p
+310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p
+718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p
+Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p
+1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p
+1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p
+153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p
+477 2796 a(principal.) 926 2937 y(2) p eop
+PStoPSsaved restore
+%%Page: (2,3) 2
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 0.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+/showpage{}def/copypage{}def/erasepage{}def
+PStoPSxform concat
+3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p
+382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p
+684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p
+1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p
+1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p
+Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p
+183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p
+759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p
+1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p
+1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p
+1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p
+463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289
+a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p
+1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p
+1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p
+1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p
+181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p
+581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p
+Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571
+a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p
+466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p
+1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p
+1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753
+571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p
+199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p
+472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631
+a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631
+a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p
+1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p
+1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p
+1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p
+403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p
+694 692 a(from) p 809 692 a(constructors) p 1086 692
+a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692
+a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p
+307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p
+702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752
+a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204
+752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p
+1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p
+1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o
+(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p
+952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff
+252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327
+939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939
+a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932
+a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585
+932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932
+a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p
+797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932
+a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939
+a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p
+Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127
+939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184
+944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p
+Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939
+a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450
+939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525
+939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633
+939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042
+a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042
+a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o
+(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042
+a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547
+1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p
+1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p
+214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162
+y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399
+1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p
+145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p
+460 1222 a(structural) p 685 1222 a(constrain) o(ts) p
+934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p
+1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222
+a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746
+1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p
+Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p
+418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p
+Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p
+967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282
+a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p
+Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282
+a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p
+365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p
+833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p
+1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515
+1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11
+1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p
+417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p
+646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015
+1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p
+1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249
+1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p
+Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p
+Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p
+753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p
+Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509
+a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629
+a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629
+a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p
+Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p
+Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757
+1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629
+a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629
+a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p
+372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p
+Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p
+Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p
+Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p
+Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689
+a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p
+1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p
+Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689
+a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689
+a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb
+1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p
+Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796
+a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796
+a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p
+1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366
+1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p
+1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p
+211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p
+Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856
+a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p
+908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856
+a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469
+1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986
+a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p
+188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p
+458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078
+a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p
+1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551
+2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11
+2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p
+290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138
+a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244
+a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh
+904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p
+Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365
+a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p
+Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120
+2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234
+2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496
+2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p
+907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531
+a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531
+a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146
+2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p
+466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926
+2937 y(3) p eop
+PStoPSsaved restore
+userdict/PStoPSsaved save put
+PStoPSmatrix setmatrix
+595.000000 421.271378 translate
+90 rotate
+0.706651 dup scale
+userdict/PStoPSmatrix matrix currentmatrix put
+userdict/PStoPSclip{0 0 moveto
+ 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
+ closepath}put initclip
+PStoPSxform concat
+4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p
+133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p
+436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p
+907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p
+1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688
+261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p
+266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p
+909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p
+1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p
+1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772
+321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p
+325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p
+666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p
+926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381
+a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p
+1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p
+1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441
+a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496
+441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p
+881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501
+y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p
+512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p
+810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk
+133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p
+482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715
+616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p
+1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p
+1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133
+676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p
+311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563
+676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p
+979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p
+272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579
+777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865
+777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p
+1200 777 a(extension,) p 1426 777 a(simpli\014cation) p
+1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p
+310 838 a(|marking) p 551 838 a(constructors) p 830 838
+a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p
+1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p
+1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p
+536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p
+1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197
+898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898
+a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p
+244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637
+958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p
+1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958
+a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669
+958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p
+469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772
+1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p
+1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018
+a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018
+a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84
+1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516
+1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p
+922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193
+a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515
+1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193
+a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p
+363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253
+a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p
+1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p
+1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p
+Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p
+380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p
+678 1490 a(other) p 812 1490 a(features:) p 1029 1490
+a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521
+1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11
+1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p
+394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p
+692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p
+978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550
+a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550
+a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p
+191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p
+647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p
+1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p
+1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11
+1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p
+283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p
+603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y)
+l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730
+a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p
+845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p
+1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730
+a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791
+y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p
+482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791
+a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p
+1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791
+a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926
+2937 y(4) p eop
+PStoPSsaved restore
+%%Trailer
+end
+userdict /end-hook known{end-hook}if
+%%EOF

diff --git a/experimental/garrigue/objvariant.diffs b/experimental/garrigue/objvariant.diffs
new file mode 100644 (file)
index 0000000..75deb24
--- /dev/null
+++ b/experimental/garrigue/objvariant.diffs
@@ -0,0 +1,354 @@
+? objvariants-3.09.1.diffs
+? objvariants.diffs
+Index: btype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
+retrieving revision 1.37.4.1
+diff -u -r1.37.4.1 btype.ml
+--- btype.ml   5 Dec 2005 13:18:42 -0000       1.37.4.1
++++ btype.ml   16 Jan 2006 02:23:14 -0000
+@@ -177,7 +177,8 @@
+     Tvariant row -> iter_row f row
+   | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
+       Misc.may (fun (_,l) -> List.iter f l) row.row_name;
+-      List.iter f row.row_bound
++      List.iter f row.row_bound;
++      List.iter (fun (s,k,t) -> f t) row.row_object
+   | _ -> assert false
+ 
+ let iter_type_expr f ty =
+@@ -224,7 +225,9 @@
+     | Some (path, tl) -> Some (path, List.map f tl) in
+   { row_fields = fields; row_more = more;
+     row_bound = !bound; row_fixed = row.row_fixed && fixed;
+-    row_closed = row.row_closed; row_name = name; }
++    row_closed = row.row_closed; row_name = name;
++    row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object;
++  }
+ 
+ let rec copy_kind = function
+     Fvar{contents = Some k} -> copy_kind k
+Index: ctype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
+retrieving revision 1.197.2.6
+diff -u -r1.197.2.6 ctype.ml
+--- ctype.ml   15 Dec 2005 02:28:38 -0000      1.197.2.6
++++ ctype.ml   16 Jan 2006 02:23:15 -0000
+@@ -1421,7 +1421,7 @@
+   newgenty
+     (Tvariant
+        {row_fields = fields; row_closed = closed; row_more = newvar();
+-        row_bound = []; row_fixed = false; row_name = None })
++        row_bound = []; row_fixed = false; row_name = None; row_object=[]})
+ 
+ (**** Unification ****)
+ 
+@@ -1724,8 +1724,11 @@
+     else None
+   in
+   let bound = row1.row_bound @ row2.row_bound in
++  let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in
++  let row_object = row1.row_object @ miss2 in
+   let row0 = {row_fields = []; row_more = more; row_bound = bound;
+-              row_closed = closed; row_fixed = fixed; row_name = name} in
++              row_closed = closed; row_fixed = fixed; row_name = name;
++              row_object = row_object } in
+   let set_more row rest =
+     let rest =
+       if closed then
+@@ -1758,6 +1761,18 @@
+           raise (Unify ((mkvariant [l,f1] true,
+                          mkvariant [l,f2] true) :: trace)))
+       pairs;
++    List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs;
++    if row_object <> [] then begin
++      List.iter
++        (fun (l,f) ->
++          match row_field_repr f with
++            Rpresent (Some ty) ->
++              let fi = build_fields generic_level row_object (newgenvar()) in
++              unify env (newgenty (Tobject (fi, ref None))) ty
++          | Rpresent None -> raise (Unify [])
++          | _ -> ())
++        (row_repr row1).row_fields
++    end;
+   with exn ->
+     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
+   end
+@@ -2789,7 +2804,8 @@
+       let row =
+         { row_fields = List.map fst fields; row_more = newvar();
+           row_bound = !bound; row_closed = posi; row_fixed = false;
+-          row_name = if c > Unchanged then None else row.row_name }
++          row_name = if c > Unchanged then None else row.row_name;
++          row_object = [] }
+       in
+       (newty (Tvariant row), Changed)
+   | Tobject (t1, _) ->
+Index: oprint.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
+retrieving revision 1.22
+diff -u -r1.22 oprint.ml
+--- oprint.ml  23 Mar 2005 03:08:37 -0000      1.22
++++ oprint.ml  16 Jan 2006 02:23:15 -0000
+@@ -185,7 +185,7 @@
+       fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
+   | Otyp_stuff s -> fprintf ppf "%s" s
+   | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
+-  | Otyp_variant (non_gen, row_fields, closed, tags) ->
++  | Otyp_variant (non_gen, row_fields, closed, tags, obj) ->
+       let print_present ppf =
+         function
+           None | Some [] -> ()
+@@ -198,12 +198,17 @@
+               ppf fields
+         | Ovar_name (id, tyl) ->
+             fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
++      and print_object ppf obj =
++        if obj <> [] then
++          fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj
+       in
+-      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
++      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a%a ]@]"
++        (if non_gen then "_" else "")
+         (if closed then if tags = None then " " else "< "
+          else if tags = None then "> " else "? ")
+         print_fields row_fields
+         print_present tags
++        print_object obj
+   | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
+       fprintf ppf "@[<1>(%a)@]" print_out_type ty
+   | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
+Index: outcometree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
+retrieving revision 1.14
+diff -u -r1.14 outcometree.mli
+--- outcometree.mli    23 Mar 2005 03:08:37 -0000      1.14
++++ outcometree.mli    16 Jan 2006 02:23:15 -0000
+@@ -59,6 +59,7 @@
+   | Otyp_var of bool * string
+   | Otyp_variant of
+       bool * out_variant * bool * (string list) option
++      * (string * out_type) list
+   | Otyp_poly of string list * out_type
+ and out_variant =
+   | Ovar_fields of (string * bool * out_type list) list
+Index: printtyp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
+retrieving revision 1.139.2.2
+diff -u -r1.139.2.2 printtyp.ml
+--- printtyp.ml        7 Dec 2005 23:37:27 -0000       1.139.2.2
++++ printtyp.ml        16 Jan 2006 02:23:15 -0000
+@@ -244,7 +244,10 @@
+             visited_objects := px :: !visited_objects;
+           match row.row_name with
+           | Some(p, tyl) when namable_row row ->
+-              List.iter (mark_loops_rec visited) tyl
++              List.iter (mark_loops_rec visited) tyl;
++              if not (static_row row) then
++                List.iter (fun (s,k,t) -> mark_loops_rec visited t)
++                  row.row_object
+           | _ ->
+               iter_row (mark_loops_rec visited) {row with row_bound = []}
+          end
+@@ -343,25 +346,27 @@
+                | _ -> false)
+             fields in
+         let all_present = List.length present = List.length fields in
++        let static = row.row_closed && all_present in
++        let obj =
++          if static then [] else
++          List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object
++        in
++        let tags = if all_present then None else Some (List.map fst present) in
+         begin match row.row_name with
+         | Some(p, tyl) when namable_row row ->
+             let id = tree_of_path p in
+             let args = tree_of_typlist sch tyl in
+-            if row.row_closed && all_present then
++            if static then
+               Otyp_constr (id, args)
+             else
+               let non_gen = is_non_gen sch px in
+-              let tags =
+-                if all_present then None else Some (List.map fst present) in
+               Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
+-                            row.row_closed, tags)
++                            row.row_closed, tags, obj)
+         | _ ->
+-            let non_gen =
+-              not (row.row_closed && all_present) && is_non_gen sch px in
++            let non_gen = not static && is_non_gen sch px in
+             let fields = List.map (tree_of_row_field sch) fields in
+-            let tags =
+-              if all_present then None else Some (List.map fst present) in
+-            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
++            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed,
++                          tags, obj)
+         end
+     | Tobject (fi, nm) ->
+         tree_of_typobject sch fi nm
+Index: typecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
+retrieving revision 1.176.2.2
+diff -u -r1.176.2.2 typecore.ml
+--- typecore.ml        11 Dec 2005 09:56:33 -0000      1.176.2.2
++++ typecore.ml        16 Jan 2006 02:23:15 -0000
+@@ -170,7 +170,8 @@
+       (* Force check of well-formedness *)
+       unify_pat pat.pat_env pat
+         (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
+-                        row_bound=[]; row_fixed=false; row_name=None}));
++                        row_bound=[]; row_fixed=false; row_name=None;
++                        row_object=[]}));
+   | _ -> ()
+ 
+ let rec iter_pattern f p =
+@@ -251,7 +252,7 @@
+       let ty = may_map (build_as_type env) p' in
+       newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
+                       row_bound=[]; row_name=None;
+-                      row_fixed=false; row_closed=false})
++                      row_fixed=false; row_closed=false; row_object=[]})
+   | Tpat_record lpl ->
+       let lbl = fst(List.hd lpl) in
+       if lbl.lbl_private = Private then p.pat_type else
+@@ -318,7 +319,8 @@
+       ([],[]) fields in
+   let row =
+     { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound;
+-      row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
++      row_closed = false; row_fixed = false; row_name = Some (path, tyl);
++      row_object = [] }
+   in
+   let ty = newty (Tvariant row) in
+   let gloc = {loc with Location.loc_ghost=true} in
+@@ -428,7 +430,8 @@
+                   row_closed = false;
+                   row_more = newvar ();
+                   row_fixed = false;
+-                  row_name = None } in
++                  row_name = None;
++                  row_object = [] } in
+       rp {
+         pat_desc = Tpat_variant(l, arg, row);
+         pat_loc = sp.ppat_loc;
+@@ -976,7 +979,8 @@
+                                   row_bound = [];
+                                   row_closed = false;
+                                   row_fixed = false;
+-                                  row_name = None});
++                                  row_name = None;
++                                  row_object = []});
+         exp_env = env }
+   | Pexp_record(lid_sexp_list, opt_sexp) ->
+       let ty = newvar() in
+@@ -1261,8 +1265,30 @@
+                   assert false
+               end
+           | _ ->
+-              (Texp_send(obj, Tmeth_name met),
+-               filter_method env met Public obj.exp_type)
++              let obj, met_ty =
++                match expand_head env obj.exp_type with
++                  {desc = Tvariant _} ->
++                    let exp_ty = newvar () in
++                    let met_ty = filter_method env met Public exp_ty in
++                    let row =
++                      {row_fields=[]; row_more=newvar();
++                       row_bound=[]; row_closed=false;
++                       row_fixed=false; row_name=None;
++                       row_object=[met, Fpresent, met_ty]} in
++                    unify_exp env obj (newty (Tvariant row));
++                    let prim = Primitive.parse_declaration 1 ["%field1"] in
++                    let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in
++                    let vd = {val_type = ty; val_kind = Val_prim prim} in
++                    let esnd =
++                      {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd);
++                       exp_loc = Location.none; exp_type = ty; exp_env = env}
++                    in
++                    ({obj with exp_type = exp_ty;
++                      exp_desc = Texp_apply(esnd,[Some obj, Required])},
++                     met_ty)
++                | _ -> (obj, filter_method env met Public obj.exp_type)
++              in
++              (Texp_send(obj, Tmeth_name met), met_ty)
+         in
+         if !Clflags.principal then begin
+           end_def ();
+Index: types.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
+retrieving revision 1.25
+diff -u -r1.25 types.ml
+--- types.ml   9 Dec 2004 12:40:53 -0000       1.25
++++ types.ml   16 Jan 2006 02:23:15 -0000
+@@ -44,7 +44,9 @@
+       row_bound: type_expr list;
+       row_closed: bool;
+       row_fixed: bool;
+-      row_name: (Path.t * type_expr list) option }
++      row_name: (Path.t * type_expr list) option;
++      row_object: (string * field_kind * type_expr) list;
++    }
+ 
+ and row_field =
+     Rpresent of type_expr option
+Index: types.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
+retrieving revision 1.25
+diff -u -r1.25 types.mli
+--- types.mli  9 Dec 2004 12:40:53 -0000       1.25
++++ types.mli  16 Jan 2006 02:23:15 -0000
+@@ -43,7 +43,9 @@
+       row_bound: type_expr list;
+       row_closed: bool;
+       row_fixed: bool;
+-      row_name: (Path.t * type_expr list) option }
++      row_name: (Path.t * type_expr list) option;
++      row_object: (string * field_kind * type_expr) list;
++    }
+ 
+ and row_field =
+     Rpresent of type_expr option
+Index: typetexp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
+retrieving revision 1.54
+diff -u -r1.54 typetexp.ml
+--- typetexp.ml        22 Jul 2005 06:42:36 -0000      1.54
++++ typetexp.ml        16 Jan 2006 02:23:15 -0000
+@@ -215,7 +215,8 @@
+           in
+           let row = { row_closed = true; row_fields = fields;
+                       row_bound = !bound; row_name = Some (path, args);
+-                      row_fixed = false; row_more = newvar () } in
++                      row_fixed = false; row_more = newvar ();
++                      row_object = [] } in
+           let static = Btype.static_row row in
+           let row =
+             if static then row else
+@@ -262,7 +263,7 @@
+       let mkfield l f =
+         newty (Tvariant {row_fields=[l,f]; row_more=newvar();
+                          row_bound=[]; row_closed=true;
+-                         row_fixed=false; row_name=None}) in
++                         row_fixed=false; row_name=None; row_object=[]}) in
+       let add_typed_field loc l f fields =
+         try
+           let f' = List.assoc l fields in
+@@ -345,7 +346,7 @@
+       let row =
+         { row_fields = List.rev fields; row_more = newvar ();
+           row_bound = !bound; row_closed = closed;
+-          row_fixed = false; row_name = !name } in
++          row_fixed = false; row_name = !name; row_object = [] } in
+       let static = Btype.static_row row in
+       let row =
+         if static then row else

diff --git a/experimental/garrigue/objvariant.ml b/experimental/garrigue/objvariant.ml
new file mode 100644 (file)
index 0000000..3233e03
--- /dev/null
+++ b/experimental/garrigue/objvariant.ml
@@ -0,0 +1,42 @@
+(* use with [cvs update -r objvariants typing] *)
+
+let f (x : [> ]) = x#m 3;;
+let o = object method m x = x+2 end;;
+f (`A o);;
+let l = [`A o; `B(object method m x = x -2 method y = 3 end)];;
+List.map f l;;
+let g = function `A x -> x#m 3 | `B x -> x#y;;
+List.map g l;;
+fun x -> ignore (x=f); List.map x l;;
+fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;;
+
+
+class cvar name =
+  object
+    method name = name
+    method print ppf = Format.pp_print_string ppf name
+  end
+
+type var = [`Var of cvar]
+
+class cint n =
+  object
+    method n = n
+    method print ppf = Format.pp_print_int ppf n
+  end
+
+class ['a] cadd (e1 : 'a) (e2 : 'a) =
+  object
+    constraint 'a = [> ]
+    method e1 = e1
+    method e2 = e2
+    method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print
+  end
+
+type 'a expr = [var | `Int of cint | `Add of 'a cadd]
+
+type expr1 = expr1 expr
+
+let print = Format.printf "%t@."
+
+let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2)))

diff --git a/experimental/garrigue/parser-lessminus.diffs b/experimental/garrigue/parser-lessminus.diffs
new file mode 100644 (file)
index 0000000..7b53530
--- /dev/null
+++ b/experimental/garrigue/parser-lessminus.diffs
@@ -0,0 +1,77 @@
+Index: parsing/parser.mly
+===================================================================
+--- parsing/parser.mly (revision 11929)
++++ parsing/parser.mly (working copy)
+@@ -319,6 +319,11 @@
+   let polyvars, core_type = varify_constructors newtypes core_type in
+   (exp, ghtyp(Ptyp_poly(polyvars,core_type)))
+ 
++let no_lessminus =
++  List.map (fun (p,e,b) ->
++    match b with None -> (p,e)
++    | Some loc -> raise (Syntaxerr.Error (Syntaxerr.Other loc)))
++
+ %}
+ 
+ /* Tokens */
+@@ -597,8 +602,9 @@
+ structure_item:
+     LET rec_flag let_bindings
+       { match $3 with
+-          [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp)
+-        | _ -> mkstr(Pstr_value($2, List.rev $3)) }
++          [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp, None] ->
++            mkstr(Pstr_eval exp)
++        | _ -> mkstr(Pstr_value($2, no_lessminus (List.rev $3))) }
+   | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
+       { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) }
+   | TYPE type_declarations
+@@ -744,7 +750,7 @@
+   | class_simple_expr simple_labeled_expr_list
+       { mkclass(Pcl_apply($1, List.rev $2)) }
+   | LET rec_flag let_bindings IN class_expr
+-      { mkclass(Pcl_let ($2, List.rev $3, $5)) }
++      { mkclass(Pcl_let ($2, no_lessminus (List.rev $3), $5)) }
+ ;
+ class_simple_expr:
+     LBRACKET core_type_comma_list RBRACKET class_longident
+@@ -981,9 +987,15 @@
+   | simple_expr simple_labeled_expr_list
+       { mkexp(Pexp_apply($1, List.rev $2)) }
+   | LET rec_flag let_bindings IN seq_expr
+-      { mkexp(Pexp_let($2, List.rev $3, $5)) }
++      { match $3 with
++        | [pat, expr, Some loc] when $2 = Nonrecursive ->
++            mkexp(Pexp_apply(
++              {pexp_desc = Pexp_ident(Lident "bind"); pexp_loc = loc},
++              ["", expr;  "", ghexp(Pexp_function("", None, [pat, $5]))]))
++        | bindings ->
++            mkexp(Pexp_let($2, no_lessminus (List.rev $3), $5)) }
+   | LET DOT simple_expr let_binding IN seq_expr
+-      { let (pat, expr) = $4 in
++      { let (pat, expr, _) = $4 in
+         mkexp(Pexp_apply($3, ["", expr;  "", ghexp(Pexp_function("", None, [pat, $6]))])) }
+   | LET MODULE UIDENT module_binding IN seq_expr
+       { mkexp(Pexp_letmodule($3, $4, $6)) }
+@@ -1197,14 +1209,17 @@
+ ;
+ let_binding:
+     val_ident fun_binding
+-      { (mkpatvar $1 1, $2) }
++      { (mkpatvar $1 1, $2, None) }
+   | val_ident COLON typevar_list DOT core_type EQUAL seq_expr
+-      { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7) }
++      { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7,
++        None) }
+   | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
+       { let exp, poly = wrap_type_annotation $4 $6 $8 in
+-        (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
++        (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp, None) }
+   | pattern EQUAL seq_expr
+-      { ($1, $3) }
++      { ($1, $3, None) }
++  | pattern LESSMINUS seq_expr
++      { ($1, $3, Some (rhs_loc 2)) }
+ ;
+ fun_binding:
+     strict_binding

diff --git a/experimental/garrigue/printers.ml b/experimental/garrigue/printers.ml
new file mode 100644 (file)
index 0000000..c80c42d
--- /dev/null
+++ b/experimental/garrigue/printers.ml
@@ -0,0 +1,11 @@
+(* $Id$ *)
+
+open Types
+
+let ignore_abbrevs ppf ab =
+  let s = match ab with
+    Mnil -> "Mnil"
+  | Mlink _ -> "Mlink _"
+  | Mcons _ -> "Mcons _"
+  in
+  Format.pp_print_string ppf s

diff --git a/experimental/garrigue/show_types.diffs b/experimental/garrigue/show_types.diffs
new file mode 100644 (file)
index 0000000..0c29195
--- /dev/null
+++ b/experimental/garrigue/show_types.diffs
@@ -0,0 +1,160 @@
+Index: typing/printtyp.ml
+===================================================================
+--- typing/printtyp.ml (revision 11316)
++++ typing/printtyp.ml (working copy)
+@@ -894,8 +894,10 @@
+       tree_of_class_declaration id decl rs :: tree_of_signature rem
+   | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
+       tree_of_cltype_declaration id decl rs :: tree_of_signature rem
+-  | _ ->
+-      assert false
++  | Tsig_class(id, decl, rs) :: _ ->
++      tree_of_class_declaration id decl rs :: []
++  | Tsig_cltype(id, decl, rs) :: _ ->
++      tree_of_cltype_declaration id decl rs :: []
+ 
+ and tree_of_modtype_declaration id decl =
+   let mty =
+Index: toplevel/topdirs.ml
+===================================================================
+--- toplevel/topdirs.ml        (revision 11316)
++++ toplevel/topdirs.ml        (working copy)
+@@ -297,10 +297,92 @@
+     !traced_functions;
+   traced_functions := []
+ 
++(* Warnings *)
++
+ let parse_warnings ppf iserr s =
+   try Warnings.parse_options iserr s
+   with Arg.Bad err -> fprintf ppf "%s.@." err
+ 
++(* Typing information *)
++
++type pkind =
++    Pvalue
++  | Ptype
++  | Pexception
++  | Pmodule
++  | Pmodtype
++  | Pclass
++  | Pcltype
++
++let name_of_kind = function
++    Pvalue -> "value"
++  | Ptype -> "type"
++  | Pexception -> "exception"
++  | Pmodule -> "module"
++  | Pmodtype -> "module type"
++  | Pclass -> "class"
++  | Pcltype -> "class type"
++
++let rec trim_modtype = function
++    Tmty_signature _ -> Tmty_signature []
++  | Tmty_functor (id, mty, mty') ->
++      Tmty_functor (id, mty, trim_modtype mty')
++  | Tmty_ident _ as mty -> mty
++
++let trim_signature = function
++    Tmty_signature sg ->
++      Tmty_signature
++        (List.map
++           (function
++               Tsig_module (id, mty, rs) ->
++                 Tsig_module (id, trim_modtype mty, rs)
++             (*| Tsig_modtype (id, Tmodtype_manifest mty) ->
++                 Tsig_modtype (id, Tmodtype_manifest (trim_modtype mty))*)
++             | item -> item)
++           sg)
++  | mty -> mty
++
++let show_type ppf kind lid =
++  let env = !Toploop.toplevel_env in
++  try
++    let id =
++      let s = match lid with
++        Longident.Lident s -> s
++      | Longident.Ldot (_,s) -> s
++      | Longident.Lapply _ -> failwith "invalid"
++      in Ident.create_persistent s
++    in
++    let item =
++      match kind with
++        Pvalue ->
++          let path, desc = Env.lookup_value lid env in
++          Tsig_value (id, desc)
++      | Ptype ->
++          let path, desc = Env.lookup_type lid env in
++          Tsig_type (id, desc, Trec_not)
++      | Pexception ->
++          let desc = Env.lookup_constructor lid env in
++          Tsig_exception (id, desc.cstr_args)
++      | Pmodule ->
++          let path, desc = Env.lookup_module lid env in
++          Tsig_module (id, trim_signature desc, Trec_not)
++      | Pmodtype ->
++          let path, desc = Env.lookup_modtype lid env in
++          Tsig_modtype (id, desc)
++      | Pclass ->
++          let path, desc = Env.lookup_class lid env in
++          Tsig_class (id, desc, Trec_not)
++      | Pcltype ->
++          let path, desc = Env.lookup_cltype lid env in
++          Tsig_cltype (id, desc, Trec_not)
++    in
++    fprintf ppf "%a@." Printtyp.signature [item]
++  with
++    Not_found ->
++      fprintf ppf "Unknown %s.@." (name_of_kind kind)
++  | Failure "invalid" ->
++      fprintf ppf "Invalid path %a@." Printtyp.longident lid
++
+ let _ =
+   Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
+   Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
+@@ -329,4 +411,19 @@
+              (Directive_string (parse_warnings std_out false));
+ 
+   Hashtbl.add directive_table "warn_error"
+-             (Directive_string (parse_warnings std_out true))
++             (Directive_string (parse_warnings std_out true));
++
++  Hashtbl.add directive_table "show_value"
++             (Directive_ident (show_type std_out Pvalue));
++  Hashtbl.add directive_table "show_type"
++             (Directive_ident (show_type std_out Ptype));
++  Hashtbl.add directive_table "show_exception"
++             (Directive_ident (show_type std_out Pexception));
++  Hashtbl.add directive_table "show_module"
++             (Directive_ident (show_type std_out Pmodule));
++  Hashtbl.add directive_table "show_module_type"
++             (Directive_ident (show_type std_out Pmodtype));
++  Hashtbl.add directive_table "show_class"
++             (Directive_ident (show_type std_out Pclass));
++  Hashtbl.add directive_table "show_class_type"
++             (Directive_ident (show_type std_out Pcltype))
+Index: parsing/parser.mly
+===================================================================
+--- parsing/parser.mly (revision 11316)
++++ parsing/parser.mly (working copy)
+@@ -1769,6 +1769,11 @@
+     LIDENT                                      { Lident $1 }
+   | mod_longident DOT LIDENT                    { Ldot($1, $3) }
+ ;
++any_longident:
++    val_ident                                   { Lident $1 }
++  | mod_longident DOT val_ident                 { Ldot($1, $3) }
++  | mod_longident                               { $1 }
++;
+ 
+ /* Toplevel directives */
+ 
+@@ -1776,7 +1781,7 @@
+     SHARP ident                 { Ptop_dir($2, Pdir_none) }
+   | SHARP ident STRING          { Ptop_dir($2, Pdir_string $3) }
+   | SHARP ident INT             { Ptop_dir($2, Pdir_int $3) }
+-  | SHARP ident val_longident   { Ptop_dir($2, Pdir_ident $3) }
++  | SHARP ident any_longident   { Ptop_dir($2, Pdir_ident $3) }
+   | SHARP ident FALSE           { Ptop_dir($2, Pdir_bool false) }
+   | SHARP ident TRUE            { Ptop_dir($2, Pdir_bool true) }
+ ;

diff --git a/experimental/garrigue/tests.ml b/experimental/garrigue/tests.ml
new file mode 100644 (file)
index 0000000..c39d152
--- /dev/null
+++ b/experimental/garrigue/tests.ml
@@ -0,0 +1,22 @@
+(* $Id$ *)
+
+let f1 = function `a x -> x=1 | `b -> true
+let f2 = function `a x -> x | `b -> true
+let f3 = function `b -> true
+let f x = f1 x && f2 x
+
+let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
+  String.sub s pos len
+
+let cCAMLtoTKpack_options w = function
+        `After v1 -> "-after"
+        | `Anchor v1 -> "-anchor"
+        | `Before v1 -> "-before"
+        | `Expand v1 -> "-expand"
+        | `Fill v1 -> "-fill"
+        | `In v1 -> "-in"
+        | `Ipadx v1 -> "-ipadx"
+        | `Ipady v1 -> "-ipady"
+        | `Padx v1 -> "-padx"
+        | `Pady v1 -> "-pady"
+        | `Side v1 -> "-side"

diff --git a/experimental/garrigue/valvirt.diffs b/experimental/garrigue/valvirt.diffs
new file mode 100644 (file)
index 0000000..2cf5574
--- /dev/null
+++ b/experimental/garrigue/valvirt.diffs
@@ -0,0 +1,2349 @@
+Index: utils/warnings.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.ml,v
+retrieving revision 1.23
+diff -u -r1.23 warnings.ml
+--- utils/warnings.ml  15 Sep 2005 03:09:26 -0000      1.23
++++ utils/warnings.ml  5 Apr 2006 02:25:59 -0000
+@@ -26,7 +26,7 @@
+   | Statement_type                   (* S *)
+   | Unused_match                     (* U *)
+   | Unused_pat
+-  | Hide_instance_variable of string (* V *)
++  | Instance_variable_override of string (* V *)
+   | Illegal_backslash                (* X *)
+   | Implicit_public_methods of string list
+   | Unerasable_optional_argument
+@@ -54,7 +54,7 @@
+   | Statement_type ->           's'
+   | Unused_match
+   | Unused_pat ->               'u'
+-  | Hide_instance_variable _ -> 'v'
++  | Instance_variable_override _ -> 'v'
+   | Illegal_backslash
+   | Implicit_public_methods _
+   | Unerasable_optional_argument
+@@ -126,9 +126,9 @@
+       String.concat " "
+         ("the following methods are overridden \
+           by the inherited class:\n " :: slist)
+-  | Hide_instance_variable lab ->
+-      "this definition of an instance variable " ^ lab ^
+-      " hides a previously\ndefined instance variable of the same name."
++  | Instance_variable_override lab ->
++      "the instance variable " ^ lab ^ " is overridden.\n" ^
++      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
+   | Partial_application ->
+       "this function application is partial,\n\
+        maybe some arguments are missing."
+Index: utils/warnings.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.mli,v
+retrieving revision 1.16
+diff -u -r1.16 warnings.mli
+--- utils/warnings.mli 15 Sep 2005 03:09:26 -0000      1.16
++++ utils/warnings.mli 5 Apr 2006 02:25:59 -0000
+@@ -26,7 +26,7 @@
+   | Statement_type                   (* S *)
+   | Unused_match                     (* U *)
+   | Unused_pat
+-  | Hide_instance_variable of string (* V *)
++  | Instance_variable_override of string (* V *)
+   | Illegal_backslash                (* X *)
+   | Implicit_public_methods of string list
+   | Unerasable_optional_argument
+Index: parsing/parser.mly
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
+retrieving revision 1.123
+diff -u -r1.123 parser.mly
+--- parsing/parser.mly 23 Mar 2005 03:08:37 -0000      1.123
++++ parsing/parser.mly 5 Apr 2006 02:25:59 -0000
+@@ -623,6 +623,8 @@
+       { [] }
+   | class_fields INHERIT class_expr parent_binder
+       { Pcf_inher ($3, $4) :: $1 }
++  | class_fields VAL virtual_value
++      { Pcf_valvirt $3 :: $1 }
+   | class_fields VAL value
+       { Pcf_val $3 :: $1 }
+   | class_fields virtual_method
+@@ -638,14 +640,20 @@
+     AS LIDENT
+           { Some $2 }
+   | /* empty */
+-          {None}
++          { None }
++;
++virtual_value:
++    MUTABLE VIRTUAL label COLON core_type
++      { $3, Mutable, $5, symbol_rloc () }
++  | VIRTUAL mutable_flag label COLON core_type
++      { $3, $2, $5, symbol_rloc () }
+ ;
+ value:
+-        mutable_flag label EQUAL seq_expr
+-          { $2, $1, $4, symbol_rloc () }
+-      | mutable_flag label type_constraint EQUAL seq_expr
+-          { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
+-            symbol_rloc () }
++    mutable_flag label EQUAL seq_expr
++      { $2, $1, $4, symbol_rloc () }
++  | mutable_flag label type_constraint EQUAL seq_expr
++      { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
++        symbol_rloc () }
+ ;
+ virtual_method:
+     METHOD PRIVATE VIRTUAL label COLON poly_type
+@@ -711,8 +719,12 @@
+   | class_sig_fields CONSTRAINT constrain       { Pctf_cstr  $3 :: $1 }
+ ;
+ value_type:
+-    mutable_flag label COLON core_type
+-      { $2, $1, Some $4, symbol_rloc () }
++    VIRTUAL mutable_flag label COLON core_type
++      { $3, $2, Virtual, $5, symbol_rloc () }
++  | MUTABLE virtual_flag label COLON core_type
++      { $3, Mutable, $2, $5, symbol_rloc () }
++  | label COLON core_type
++      { $1, Immutable, Concrete, $3, symbol_rloc () }
+ ;
+ method_type:
+     METHOD private_flag label COLON poly_type
+Index: parsing/parsetree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
+retrieving revision 1.42
+diff -u -r1.42 parsetree.mli
+--- parsing/parsetree.mli      23 Mar 2005 03:08:37 -0000      1.42
++++ parsing/parsetree.mli      5 Apr 2006 02:25:59 -0000
+@@ -152,7 +152,7 @@
+ 
+ and class_type_field =
+     Pctf_inher of class_type
+-  | Pctf_val   of (string * mutable_flag * core_type option * Location.t)
++  | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t)
+   | Pctf_virt  of (string * private_flag * core_type * Location.t)
+   | Pctf_meth  of (string * private_flag * core_type * Location.t)
+   | Pctf_cstr  of (core_type * core_type * Location.t)
+@@ -179,6 +179,7 @@
+ 
+ and class_field =
+     Pcf_inher of class_expr * string option
++  | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
+   | Pcf_val   of (string * mutable_flag * expression * Location.t)
+   | Pcf_virt  of (string * private_flag * core_type * Location.t)
+   | Pcf_meth  of (string * private_flag * expression * Location.t)
+Index: parsing/printast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
+retrieving revision 1.29
+diff -u -r1.29 printast.ml
+--- parsing/printast.ml        4 Jan 2006 16:55:50 -0000       1.29
++++ parsing/printast.ml        5 Apr 2006 02:25:59 -0000
+@@ -353,10 +353,11 @@
+   | Pctf_inher (ct) ->
+       line i ppf "Pctf_inher\n";
+       class_type i ppf ct;
+-  | Pctf_val (s, mf, cto, loc) ->
++  | Pctf_val (s, mf, vf, ct, loc) ->
+       line i ppf
+-        "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
+-      option i core_type ppf cto;
++        "Pctf_val \"%s\" %a %a %a\n" s
++        fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
++      core_type (i+1) ppf ct;
+   | Pctf_virt (s, pf, ct, loc) ->
+       line i ppf
+         "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+@@ -428,6 +429,10 @@
+       line i ppf "Pcf_inher\n";
+       class_expr (i+1) ppf ce;
+       option (i+1) string ppf so;
++  | Pcf_valvirt (s, mf, ct, loc) ->
++      line i ppf
++        "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
++      core_type (i+1) ppf ct;
+   | Pcf_val (s, mf, e, loc) ->
+       line i ppf
+         "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
+Index: typing/btype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
+retrieving revision 1.38
+diff -u -r1.38 btype.ml
+--- typing/btype.ml    4 Jan 2006 16:55:50 -0000       1.38
++++ typing/btype.ml    5 Apr 2006 02:25:59 -0000
+@@ -330,7 +330,7 @@
+ 
+ let unmark_class_signature sign =
+   unmark_type sign.cty_self;
+-  Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars
++  Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars
+ 
+ let rec unmark_class_type =
+   function
+Index: typing/ctype.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
+retrieving revision 1.200
+diff -u -r1.200 ctype.ml
+--- typing/ctype.ml    6 Jan 2006 02:16:24 -0000       1.200
++++ typing/ctype.ml    5 Apr 2006 02:25:59 -0000
+@@ -857,7 +857,7 @@
+         Tcty_signature
+           {cty_self = copy sign.cty_self;
+            cty_vars =
+-             Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
++             Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars;
+            cty_concr = sign.cty_concr;
+            cty_inher =
+              List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
+@@ -2354,10 +2354,11 @@
+   | CM_Val_type_mismatch of string * (type_expr * type_expr) list
+   | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
+   | CM_Non_mutable_value of string
++  | CM_Non_concrete_value of string
+   | CM_Missing_value of string
+   | CM_Missing_method of string
+   | CM_Hide_public of string
+-  | CM_Hide_virtual of string
++  | CM_Hide_virtual of string * string
+   | CM_Public_method of string
+   | CM_Private_method of string
+   | CM_Virtual_method of string
+@@ -2390,8 +2391,8 @@
+            end)
+         pairs;
+       Vars.iter
+-        (fun lab (mut, ty) ->
+-           let (mut', ty') = Vars.find lab sign1.cty_vars in
++        (fun lab (mut, v, ty) ->
++           let (mut', v', ty') = Vars.find lab sign1.cty_vars in
+            try moregen true type_pairs env ty' ty with Unify trace ->
+              raise (Failure [CM_Val_type_mismatch
+                                 (lab, expand_trace env trace)]))
+@@ -2437,7 +2438,7 @@
+              end
+            in
+            if Concr.mem lab sign1.cty_concr then err
+-           else CM_Hide_virtual lab::err)
++           else CM_Hide_virtual ("method", lab) :: err)
+         miss1 []
+     in
+     let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+@@ -2455,11 +2456,13 @@
+     in
+     let error =
+       Vars.fold
+-        (fun lab (mut, ty) err ->
++        (fun lab (mut, vr, ty) err ->
+           try
+-            let (mut', ty') = Vars.find lab sign1.cty_vars in
++            let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
+             if mut = Mutable && mut' <> Mutable then
+               CM_Non_mutable_value lab::err
++            else if vr = Concrete && vr' <> Concrete then
++              CM_Non_concrete_value lab::err
+             else
+               err
+           with Not_found ->
+@@ -2467,6 +2470,14 @@
+         sign2.cty_vars error
+     in
+     let error =
++      Vars.fold
++        (fun lab (_,vr,_) err ->
++          if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
++            CM_Hide_virtual ("instance variable", lab) :: err
++          else err)
++        sign1.cty_vars error
++    in
++    let error =
+       List.fold_right
+         (fun e l ->
+            if List.mem e missing_method then l else CM_Virtual_method e::l)
+@@ -2516,8 +2527,8 @@
+              end)
+           pairs;
+         Vars.iter
+-          (fun lab (mut, ty) ->
+-             let (mut', ty') = Vars.find lab sign1.cty_vars in
++          (fun lab (_, _, ty) ->
++             let (_, _, ty') = Vars.find lab sign1.cty_vars in
+              try eqtype true type_pairs subst env ty ty' with Unify trace ->
+                raise (Failure [CM_Val_type_mismatch
+                                   (lab, expand_trace env trace)]))
+@@ -2554,7 +2565,7 @@
+           end
+         in
+         if Concr.mem lab sign1.cty_concr then err
+-        else CM_Hide_virtual lab::err)
++        else CM_Hide_virtual ("method", lab) :: err)
+       miss1 []
+   in
+   let missing_method = List.map (fun (m, _, _) -> m) miss2 in
+@@ -2578,11 +2589,13 @@
+   in
+   let error =
+     Vars.fold
+-      (fun lab (mut, ty) err ->
++      (fun lab (mut, vr, ty) err ->
+          try
+-           let (mut', ty') = Vars.find lab sign1.cty_vars in
++           let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
+            if mut = Mutable && mut' <> Mutable then
+              CM_Non_mutable_value lab::err
++           else if vr = Concrete && vr' <> Concrete then
++             CM_Non_concrete_value lab::err
+            else
+              err
+          with Not_found ->
+@@ -2590,6 +2603,14 @@
+       sign2.cty_vars error
+   in
+   let error =
++    Vars.fold
++      (fun lab (_,vr,_) err ->
++        if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
++          CM_Hide_virtual ("instance variable", lab) :: err
++        else err)
++      sign1.cty_vars error
++  in
++  let error =
+     List.fold_right
+       (fun e l ->
+         if List.mem e missing_method then l else CM_Virtual_method e::l)
+@@ -3279,7 +3300,7 @@
+ let nondep_class_signature env id sign =
+   { cty_self = nondep_type_rec env id sign.cty_self;
+     cty_vars =
+-      Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
++      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
+         sign.cty_vars;
+     cty_concr = sign.cty_concr;
+     cty_inher =
+Index: typing/ctype.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
+retrieving revision 1.53
+diff -u -r1.53 ctype.mli
+--- typing/ctype.mli   9 Dec 2004 12:40:53 -0000       1.53
++++ typing/ctype.mli   5 Apr 2006 02:25:59 -0000
+@@ -170,10 +170,11 @@
+   | CM_Val_type_mismatch of string * (type_expr * type_expr) list
+   | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
+   | CM_Non_mutable_value of string
++  | CM_Non_concrete_value of string
+   | CM_Missing_value of string
+   | CM_Missing_method of string
+   | CM_Hide_public of string
+-  | CM_Hide_virtual of string
++  | CM_Hide_virtual of string * string
+   | CM_Public_method of string
+   | CM_Private_method of string
+   | CM_Virtual_method of string
+Index: typing/includeclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/includeclass.ml,v
+retrieving revision 1.7
+diff -u -r1.7 includeclass.ml
+--- typing/includeclass.ml     6 Mar 2000 22:11:57 -0000       1.7
++++ typing/includeclass.ml     5 Apr 2006 02:25:59 -0000
+@@ -78,14 +78,17 @@
+   | CM_Non_mutable_value lab ->
+       fprintf ppf
+        "@[The non-mutable instance variable %s cannot become mutable@]" lab
++  | CM_Non_concrete_value lab ->
++      fprintf ppf
++       "@[The virtual instance variable %s cannot become concrete@]" lab
+   | CM_Missing_value lab ->
+       fprintf ppf "@[The first class type has no instance variable %s@]" lab
+   | CM_Missing_method lab ->
+       fprintf ppf "@[The first class type has no method %s@]" lab
+   | CM_Hide_public lab ->
+      fprintf ppf "@[The public method %s cannot be hidden@]" lab
+-  | CM_Hide_virtual lab ->
+-      fprintf ppf "@[The virtual method %s cannot be hidden@]" lab
++  | CM_Hide_virtual (k, lab) ->
++      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
+   | CM_Public_method lab ->
+       fprintf ppf "@[The public method %s cannot become private" lab
+   | CM_Virtual_method lab ->
+Index: typing/oprint.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
+retrieving revision 1.22
+diff -u -r1.22 oprint.ml
+--- typing/oprint.ml   23 Mar 2005 03:08:37 -0000      1.22
++++ typing/oprint.ml   5 Apr 2006 02:25:59 -0000
+@@ -291,8 +291,10 @@
+       fprintf ppf "@[<2>method %s%s%s :@ %a@]"
+         (if priv then "private " else "") (if virt then "virtual " else "")
+         name !out_type ty
+-  | Ocsg_value (name, mut, ty) ->
+-      fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "")
++  | Ocsg_value (name, mut, vr, ty) ->
++      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
++        (if mut then "mutable " else "")
++        (if vr then "virtual " else "")
+         name !out_type ty
+ 
+ let out_class_type = ref print_out_class_type
+Index: typing/outcometree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
+retrieving revision 1.14
+diff -u -r1.14 outcometree.mli
+--- typing/outcometree.mli     23 Mar 2005 03:08:37 -0000      1.14
++++ typing/outcometree.mli     5 Apr 2006 02:25:59 -0000
+@@ -71,7 +71,7 @@
+ and out_class_sig_item =
+   | Ocsg_constraint of out_type * out_type
+   | Ocsg_method of string * bool * bool * out_type
+-  | Ocsg_value of string * bool * out_type
++  | Ocsg_value of string * bool * bool * out_type
+ 
+ type out_module_type =
+   | Omty_abstract
+Index: typing/printtyp.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
+retrieving revision 1.140
+diff -u -r1.140 printtyp.ml
+--- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000       1.140
++++ typing/printtyp.ml 5 Apr 2006 02:26:00 -0000
+@@ -650,7 +650,7 @@
+         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
+       in
+       List.iter (fun met -> mark_loops (method_type met)) fields;
+-      Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
++      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
+   | Tcty_fun (_, ty, cty) ->
+       mark_loops ty;
+       prepare_class_type params cty
+@@ -682,13 +682,15 @@
+           csil (tree_of_constraints params)
+       in
+       let all_vars =
+-        Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in
++        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars []
++      in
+       (* Consequence of PR#3607: order of Map.fold has changed! *)
+       let all_vars = List.rev all_vars in
+       let csil =
+         List.fold_left
+-          (fun csil (l, m, t) ->
+-             Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil)
++          (fun csil (l, m, v, t) ->
++            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
++            :: csil)
+           csil all_vars
+       in
+       let csil =
+@@ -763,7 +765,9 @@
+     List.exists
+       (fun (lab, _, ty) ->
+          not (lab = dummy_method || Concr.mem lab sign.cty_concr))
+-      fields in
++      fields
++    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false
++  in
+ 
+   Osig_class_type
+     (virt, Ident.name id,
+Index: typing/subst.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/subst.ml,v
+retrieving revision 1.49
+diff -u -r1.49 subst.ml
+--- typing/subst.ml    4 Jan 2006 16:55:50 -0000       1.49
++++ typing/subst.ml    5 Apr 2006 02:26:00 -0000
+@@ -178,7 +178,8 @@
+ 
+ let class_signature s sign =
+   { cty_self = typexp s sign.cty_self;
+-    cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
++    cty_vars =
++      Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars;
+     cty_concr = sign.cty_concr;
+     cty_inher =
+       List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
+Index: typing/typeclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
+retrieving revision 1.85
+diff -u -r1.85 typeclass.ml
+--- typing/typeclass.ml        22 Jul 2005 06:42:36 -0000      1.85
++++ typing/typeclass.ml        5 Apr 2006 02:26:00 -0000
+@@ -24,7 +24,7 @@
+ 
+ type error =
+     Unconsistent_constraint of (type_expr * type_expr) list
+-  | Method_type_mismatch of string * (type_expr * type_expr) list
++  | Field_type_mismatch of string * string * (type_expr * type_expr) list
+   | Structure_expected of class_type
+   | Cannot_apply of class_type
+   | Apply_wrong_label of label
+@@ -36,7 +36,7 @@
+   | Unbound_class_type_2 of Longident.t
+   | Abbrev_type_clash of type_expr * type_expr * type_expr
+   | Constructor_type_mismatch of string * (type_expr * type_expr) list
+-  | Virtual_class of bool * string list
++  | Virtual_class of bool * string list * string list
+   | Parameter_arity_mismatch of Longident.t * int * int
+   | Parameter_mismatch of (type_expr * type_expr) list
+   | Bad_parameters of Ident.t * type_expr * type_expr
+@@ -49,6 +49,7 @@
+   | Non_collapsable_conjunction of
+       Ident.t * Types.class_declaration * (type_expr * type_expr) list
+   | Final_self_clash of (type_expr * type_expr) list
++  | Mutability_mismatch of string * mutable_flag
+ 
+ exception Error of Location.t * error
+ 
+@@ -90,7 +91,7 @@
+       generalize_class_type cty
+   | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
+       Ctype.generalize sty;
+-      Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
++      Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars;
+       List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
+   | Tcty_fun (_, ty, cty) ->
+       Ctype.generalize ty;
+@@ -152,7 +153,7 @@
+   | Tcty_signature sign ->
+       Ctype.closed_schema sign.cty_self
+         &&
+-      Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc)
++      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc)
+         sign.cty_vars
+         true
+   | Tcty_fun (_, ty, cty) ->
+@@ -172,7 +173,7 @@
+       limited_generalize rv cty
+   | Tcty_signature sign ->
+       Ctype.limited_generalize rv sign.cty_self;
+-      Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
++      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
+         sign.cty_vars;
+       List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+         sign.cty_inher
+@@ -201,11 +202,25 @@
+    Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
+ 
+ (* Enter an instance variable in the environment *)
+-let enter_val cl_num vars lab mut ty val_env met_env par_env =
+-  let (id, val_env, met_env, par_env) as result =
+-    enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
++let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
++  let (id, virt) =
++    try
++      let (id, mut', virt', ty') = Vars.find lab !vars in
++      if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
++      Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
++      (if not inh then Some id else None),
++      (if virt' = Concrete then virt' else virt)
++    with
++      Ctype.Unify tr ->
++        raise (Error(loc, Field_type_mismatch("instance variable", lab, tr)))
++    | Not_found -> None, virt
++  in
++  let (id, _, _, _) as result =
++    match id with Some id -> (id, val_env, met_env, par_env)
++    | None ->
++        enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
+   in
+-  vars := Vars.add lab (id, mut, ty) !vars;
++  vars := Vars.add lab (id, mut, virt, ty) !vars;
+   result
+ 
+ let inheritance self_type env concr_meths warn_meths loc parent =
+@@ -218,7 +233,7 @@
+       with Ctype.Unify trace ->
+         match trace with
+           _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
+-            raise(Error(loc, Method_type_mismatch (n, rem)))
++            raise(Error(loc, Field_type_mismatch ("method", n, rem)))
+         | _ ->
+             assert false
+       end;
+@@ -243,7 +258,7 @@
+   in
+   let ty = transl_simple_type val_env false sty in
+   try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+-    raise(Error(loc, Method_type_mismatch (lab, trace)))
++    raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+ 
+ let delayed_meth_specs = ref []
+ 
+@@ -253,7 +268,7 @@
+   in
+   let unif ty =
+     try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
+-      raise(Error(loc, Method_type_mismatch (lab, trace)))
++      raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+   in
+   match sty.ptyp_desc, priv with
+     Ptyp_poly ([],sty), Public ->
+@@ -279,6 +294,15 @@
+ 
+ (*******************************)
+ 
++let add_val env loc lab (mut, virt, ty) val_sig = 
++  let virt =
++    try
++      let (mut', virt', ty') = Vars.find lab val_sig in
++      if virt' = Concrete then virt' else virt
++    with Not_found -> virt
++  in
++  Vars.add lab (mut, virt, ty) val_sig
++
+ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
+   function
+     Pctf_inher sparent ->
+@@ -293,25 +317,12 @@
+           parent
+       in
+       let val_sig =
+-        Vars.fold
+-          (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
+-          cl_sig.cty_vars val_sig
+-      in
++        Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in
+       (val_sig, concr_meths, inher)
+ 
+-  | Pctf_val (lab, mut, sty_opt, loc) ->
+-      let (mut, ty) =
+-        match sty_opt with
+-          None     ->
+-            let (mut', ty) =
+-              try Vars.find lab val_sig with Not_found ->
+-                raise(Error(loc, Unbound_val lab))
+-            in
+-            (if mut = Mutable then mut' else Immutable), ty
+-        | Some sty ->
+-            mut, transl_simple_type env false sty
+-      in
+-      (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
++  | Pctf_val (lab, mut, virt, sty, loc) ->
++      let ty = transl_simple_type env false sty in
++      (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher)
+ 
+   | Pctf_virt (lab, priv, sty, loc) ->
+       declare_method env meths self_type lab priv sty loc;
+@@ -397,7 +408,7 @@
+ 
+ let rec class_field cl_num self_type meths vars
+     (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+-     inh_vals, inher) =
++     warn_vals, inher) =
+   function
+     Pcf_inher (sparent, super) ->
+       let parent = class_expr cl_num val_env par_env sparent in
+@@ -411,18 +422,23 @@
+           parent.cl_type
+       in
+       (* Variables *)
+-      let (val_env, met_env, par_env, inh_vars, inh_vals) =
++      let (val_env, met_env, par_env, inh_vars, warn_vals) =
+         Vars.fold
+-          (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) ->
++          (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) ->
++             let mut, vr, ty = info in
+              let (id, val_env, met_env, par_env) =
+-               enter_val cl_num vars lab mut ty val_env met_env par_env
++               enter_val cl_num vars true lab mut vr ty val_env met_env par_env
++                 sparent.pcl_loc
+              in
+-             if StringSet.mem lab inh_vals then
+-               Location.prerr_warning sparent.pcl_loc
+-                 (Warnings.Hide_instance_variable lab);
+-             (val_env, met_env, par_env, (lab, id) :: inh_vars,
+-              StringSet.add lab inh_vals))
+-          cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals)
++             let warn_vals =
++               if vr = Virtual then warn_vals else
++               if StringSet.mem lab warn_vals then
++                 (Location.prerr_warning sparent.pcl_loc
++                   (Warnings.Instance_variable_override lab); warn_vals)
++               else StringSet.add lab warn_vals
++             in
++             (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals))
++          cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals)
+       in
+       (* Inherited concrete methods *)
+       let inh_meths = 
+@@ -443,11 +459,26 @@
+       in
+       (val_env, met_env, par_env,
+        lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
+-       concr_meths, warn_meths, inh_vals, inher)
++       concr_meths, warn_meths, warn_vals, inher)
++
++  | Pcf_valvirt (lab, mut, styp, loc) ->
++      if !Clflags.principal then Ctype.begin_def ();
++      let ty = Typetexp.transl_simple_type val_env false styp in
++      if !Clflags.principal then begin
++        Ctype.end_def ();
++        Ctype.generalize_structure ty
++      end;
++      let (id, val_env, met_env', par_env) =
++        enter_val cl_num vars false lab mut Virtual ty
++          val_env met_env par_env loc
++      in
++      (val_env, met_env', par_env,
++       lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields,
++       concr_meths, warn_meths, StringSet.remove lab warn_vals, inher)
+ 
+   | Pcf_val (lab, mut, sexp, loc) ->
+-      if StringSet.mem lab inh_vals then
+-        Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
++      if StringSet.mem lab warn_vals then
++        Location.prerr_warning loc (Warnings.Instance_variable_override lab);
+       if !Clflags.principal then Ctype.begin_def ();
+       let exp =
+         try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
+@@ -457,17 +488,19 @@
+         Ctype.end_def ();
+         Ctype.generalize_structure exp.exp_type
+       end;
+-      let (id, val_env, met_env, par_env) =
+-        enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
+-      in
+-      (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
+-       concr_meths, warn_meths, inh_vals, inher)
++      let (id, val_env, met_env', par_env) =
++        enter_val cl_num vars false lab mut Concrete exp.exp_type
++          val_env met_env par_env loc
++      in
++      (val_env, met_env', par_env,
++       lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields,
++       concr_meths, warn_meths, StringSet.add lab warn_vals, inher)
+ 
+   | Pcf_virt (lab, priv, sty, loc) ->
+       virtual_method val_env meths self_type lab priv sty loc;
+       let warn_meths = Concr.remove lab warn_meths in
+       (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+-       inh_vals, inher)
++       warn_vals, inher)
+ 
+   | Pcf_meth (lab, priv, expr, loc)  ->
+       let (_, ty) =
+@@ -493,7 +526,7 @@
+           end
+       | _ -> assert false
+       with Ctype.Unify trace ->
+-        raise(Error(loc, Method_type_mismatch (lab, trace)))
++        raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+       end;
+       let meth_expr = make_method cl_num expr in
+       (* backup variables for Pexp_override *)
+@@ -510,12 +543,12 @@
+           Cf_meth (lab, texp)
+         end in
+       (val_env, met_env, par_env, field::fields,
+-       Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
++       Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher)
+ 
+   | Pcf_cstr (sty, sty', loc) ->
+       type_constraint val_env sty sty' loc;
+       (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+-       inh_vals, inher)
++       warn_vals, inher)
+ 
+   | Pcf_let (rec_flag, sdefs, loc) ->
+       let (defs, val_env) =
+@@ -545,7 +578,7 @@
+           ([], met_env, par_env)
+       in
+       (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
+-       concr_meths, warn_meths, inh_vals, inher)
++       concr_meths, warn_meths, warn_vals, inher)
+ 
+   | Pcf_init expr ->
+       let expr = make_method cl_num expr in
+@@ -562,7 +595,7 @@
+           Cf_init texp
+         end in
+       (val_env, met_env, par_env, field::fields,
+-       concr_meths, warn_meths, inh_vals, inher)
++       concr_meths, warn_meths, warn_vals, inher)
+ 
+ and class_structure cl_num final val_env met_env loc (spat, str) =
+   (* Environment for substructures *)
+@@ -616,7 +649,7 @@
+   Ctype.unify val_env self_type (Ctype.newvar ());
+   let sign =
+     {cty_self = public_self;
+-     cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
++     cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
+      cty_concr = concr_meths;
+      cty_inher = inher} in
+   let methods = get_methods self_type in
+@@ -628,7 +661,11 @@
+        be modified after this point *)
+     Ctype.close_object self_type;
+     let mets = virtual_methods {sign with cty_self = self_type} in
+-    if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
++    let vals =
++      Vars.fold
++        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
++        sign.cty_vars [] in
++    if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals)));
+     let self_methods =
+       List.fold_right
+         (fun (lab,kind,ty) rem ->
+@@ -1135,9 +1172,14 @@
+   in
+ 
+   if cl.pci_virt = Concrete then begin
+-    match virtual_methods (Ctype.signature_of_class_type typ) with
+-      []   -> ()
+-    | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
++    let sign = Ctype.signature_of_class_type typ in
++    let mets = virtual_methods sign in
++    let vals =
++      Vars.fold
++        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
++        sign.cty_vars [] in
++    if mets <> []  || vals <> [] then
++      raise(Error(cl.pci_loc, Virtual_class(true, mets, vals)));
+   end;
+ 
+   (* Misc. *)
+@@ -1400,10 +1442,10 @@
+       Printtyp.report_unification_error ppf trace
+         (fun ppf -> fprintf ppf "Type")
+         (fun ppf -> fprintf ppf "is not compatible with type")
+-  | Method_type_mismatch (m, trace) ->
++  | Field_type_mismatch (k, m, trace) ->
+       Printtyp.report_unification_error ppf trace
+         (function ppf ->
+-           fprintf ppf "The method %s@ has type" m)
++           fprintf ppf "The %s %s@ has type" k m)
+         (function ppf ->
+            fprintf ppf "but is expected to have type")
+   | Structure_expected clty ->
+@@ -1451,15 +1493,20 @@
+            fprintf ppf "The expression \"new %s\" has type" c)
+         (function ppf ->
+            fprintf ppf "but is used with type")
+-  | Virtual_class (cl, mets) ->
++  | Virtual_class (cl, mets, vals) ->
+       let print_mets ppf mets =
+         List.iter (function met -> fprintf ppf "@ %s" met) mets in
+       let cl_mark = if cl then "" else " type" in
++      let missings =
++        match mets, vals with
++          [], _ -> "variables"
++        | _, [] -> "methods"
++        | _ -> "methods and variables"
++      in
+       fprintf ppf
+-        "@[This class%s should be virtual@ \
+-           @[<2>The following methods are undefined :%a@]
+-         @]"
+-        cl_mark print_mets mets
++        "@[This class%s should be virtual.@ \
++           @[<2>The following %s are undefined :%a@]@]"
++          cl_mark missings print_mets (mets @ vals)
+   | Parameter_arity_mismatch(lid, expected, provided) ->
+       fprintf ppf
+         "@[The class constructor %a@ expects %i type argument(s),@ \
+@@ -1532,3 +1579,10 @@
+            fprintf ppf "This object is expected to have type")
+         (function ppf ->
+            fprintf ppf "but has actually type")
++  | Mutability_mismatch (lab, mut) ->
++      let mut1, mut2 =
++        if mut = Immutable then "mutable", "immutable"
++        else "immutable", "mutable" in
++      fprintf ppf
++        "@[The instance variable is %s,@ it cannot be redefined as %s@]"
++        mut1 mut2
+Index: typing/typeclass.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.mli,v
+retrieving revision 1.18
+diff -u -r1.18 typeclass.mli
+--- typing/typeclass.mli       1 Dec 2003 00:32:11 -0000       1.18
++++ typing/typeclass.mli       5 Apr 2006 02:26:00 -0000
+@@ -49,7 +49,7 @@
+ 
+ type error =
+     Unconsistent_constraint of (type_expr * type_expr) list
+-  | Method_type_mismatch of string * (type_expr * type_expr) list
++  | Field_type_mismatch of string * string * (type_expr * type_expr) list
+   | Structure_expected of class_type
+   | Cannot_apply of class_type
+   | Apply_wrong_label of label
+@@ -61,7 +61,7 @@
+   | Unbound_class_type_2 of Longident.t
+   | Abbrev_type_clash of type_expr * type_expr * type_expr
+   | Constructor_type_mismatch of string * (type_expr * type_expr) list
+-  | Virtual_class of bool * string list
++  | Virtual_class of bool * string list * string list
+   | Parameter_arity_mismatch of Longident.t * int * int
+   | Parameter_mismatch of (type_expr * type_expr) list
+   | Bad_parameters of Ident.t * type_expr * type_expr
+@@ -74,6 +74,7 @@
+   | Non_collapsable_conjunction of
+       Ident.t * Types.class_declaration * (type_expr * type_expr) list
+   | Final_self_clash of (type_expr * type_expr) list
++  | Mutability_mismatch of string * mutable_flag
+ 
+ exception Error of Location.t * error
+ 
+Index: typing/typecore.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
+retrieving revision 1.178
+diff -u -r1.178 typecore.ml
+--- typing/typecore.ml 6 Jan 2006 02:25:37 -0000       1.178
++++ typing/typecore.ml 5 Apr 2006 02:26:00 -0000
+@@ -611,11 +611,11 @@
+       List.for_all
+         (function
+             Cf_meth _ -> true
+-          | Cf_val (_,_,e) -> incr count; is_nonexpansive e
++          | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
+           | Cf_init e -> is_nonexpansive e
+           | Cf_inher _ | Cf_let _ -> false)
+         fields &&
+-      Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
++      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
+         vars true &&
+       !count = 0
+   | _ -> false
+@@ -1356,7 +1356,7 @@
+         (path_self, _) ->
+           let type_override (lab, snewval) =
+             begin try
+-              let (id, _, ty) = Vars.find lab !vars in
++              let (id, _, _, ty) = Vars.find lab !vars in
+               (Path.Pident id, type_expect env snewval (instance ty))
+             with
+               Not_found ->
+Index: typing/typecore.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.mli,v
+retrieving revision 1.37
+diff -u -r1.37 typecore.mli
+--- typing/typecore.mli        4 Mar 2005 14:51:31 -0000       1.37
++++ typing/typecore.mli        5 Apr 2006 02:26:00 -0000
+@@ -38,7 +38,8 @@
+         string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
+         Typedtree.pattern *
+         (Ident.t * type_expr) Meths.t ref *
+-        (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
++        (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
++            Vars.t ref *
+         Env.t * Env.t * Env.t
+ val type_expect:
+         ?in_function:(Location.t * type_expr) ->
+Index: typing/typedtree.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.ml,v
+retrieving revision 1.36
+diff -u -r1.36 typedtree.ml
+--- typing/typedtree.ml        25 Nov 2003 09:20:43 -0000      1.36
++++ typing/typedtree.ml        5 Apr 2006 02:26:00 -0000
+@@ -106,7 +106,7 @@
+ 
+ and class_field =
+     Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
+-  | Cf_val of string * Ident.t * expression
++  | Cf_val of string * Ident.t * expression option * bool
+   | Cf_meth of string * expression
+   | Cf_let of rec_flag * (pattern * expression) list *
+               (Ident.t * expression) list
+@@ -140,7 +140,8 @@
+   | Tstr_recmodule of (Ident.t * module_expr) list
+   | Tstr_modtype of Ident.t * module_type
+   | Tstr_open of Path.t
+-  | Tstr_class of (Ident.t * int * string list * class_expr) list
++  | Tstr_class of
++      (Ident.t * int * string list * class_expr * virtual_flag) list
+   | Tstr_cltype of (Ident.t * cltype_declaration) list
+   | Tstr_include of module_expr * Ident.t list
+ 
+Index: typing/typedtree.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.mli,v
+retrieving revision 1.34
+diff -u -r1.34 typedtree.mli
+--- typing/typedtree.mli       25 Nov 2003 09:20:43 -0000      1.34
++++ typing/typedtree.mli       5 Apr 2006 02:26:00 -0000
+@@ -107,7 +107,8 @@
+ and class_field =
+     Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
+     (* Inherited instance variables and concrete methods *)
+-  | Cf_val of string * Ident.t * expression
++  | Cf_val of string * Ident.t * expression option * bool
++        (* None = virtual, true = override *)
+   | Cf_meth of string * expression
+   | Cf_let of rec_flag * (pattern * expression) list *
+               (Ident.t * expression) list
+@@ -141,7 +142,8 @@
+   | Tstr_recmodule of (Ident.t * module_expr) list
+   | Tstr_modtype of Ident.t * module_type
+   | Tstr_open of Path.t
+-  | Tstr_class of (Ident.t * int * string list * class_expr) list
++  | Tstr_class of
++      (Ident.t * int * string list * class_expr * virtual_flag) list
+   | Tstr_cltype of (Ident.t * cltype_declaration) list
+   | Tstr_include of module_expr * Ident.t list
+ 
+Index: typing/typemod.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/typemod.ml,v
+retrieving revision 1.73
+diff -u -r1.73 typemod.ml
+--- typing/typemod.ml  8 Aug 2005 09:41:51 -0000       1.73
++++ typing/typemod.ml  5 Apr 2006 02:26:00 -0000
+@@ -17,6 +17,7 @@
+ open Misc
+ open Longident
+ open Path
++open Asttypes
+ open Parsetree
+ open Types
+ open Typedtree
+@@ -667,8 +668,9 @@
+         let (classes, new_env) = Typeclass.class_declarations env cl in
+         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
+         (Tstr_class
+-           (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) ->
+-              (i, s, m, c)) classes) ::
++           (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) ->
++              let vf = if d.cty_new = None then Virtual else Concrete in
++              (i, s, m, c, vf)) classes) ::
+          Tstr_cltype
+            (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) ::
+          Tstr_type
+Index: typing/types.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
+retrieving revision 1.25
+diff -u -r1.25 types.ml
+--- typing/types.ml    9 Dec 2004 12:40:53 -0000       1.25
++++ typing/types.ml    5 Apr 2006 02:26:00 -0000
+@@ -90,7 +90,8 @@
+   | Val_prim of Primitive.description   (* Primitive *)
+   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+   | Val_self of (Ident.t * type_expr) Meths.t ref *
+-                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
++                (Ident.t * Asttypes.mutable_flag *
++                 Asttypes.virtual_flag * type_expr) Vars.t ref *
+                 string * type_expr
+                                         (* Self *)
+   | Val_anc of (string * Ident.t) list * string
+@@ -156,7 +157,8 @@
+ 
+ and class_signature =
+   { cty_self: type_expr;
+-    cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
++    cty_vars:
++      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+     cty_concr: Concr.t;
+     cty_inher: (Path.t * type_expr list) list }
+ 
+Index: typing/types.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
+retrieving revision 1.25
+diff -u -r1.25 types.mli
+--- typing/types.mli   9 Dec 2004 12:40:53 -0000       1.25
++++ typing/types.mli   5 Apr 2006 02:26:00 -0000
+@@ -91,7 +91,8 @@
+   | Val_prim of Primitive.description   (* Primitive *)
+   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
+   | Val_self of (Ident.t * type_expr) Meths.t ref *
+-                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
++                (Ident.t * Asttypes.mutable_flag *
++                 Asttypes.virtual_flag * type_expr) Vars.t ref *
+                 string * type_expr
+                                         (* Self *)
+   | Val_anc of (string * Ident.t) list * string
+@@ -158,7 +159,8 @@
+ 
+ and class_signature =
+   { cty_self: type_expr;
+-    cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
++    cty_vars:
++      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
+     cty_concr: Concr.t;
+     cty_inher: (Path.t * type_expr list) list }
+ 
+Index: typing/unused_var.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
+retrieving revision 1.5
+diff -u -r1.5 unused_var.ml
+--- typing/unused_var.ml       4 Jan 2006 16:55:50 -0000       1.5
++++ typing/unused_var.ml       5 Apr 2006 02:26:00 -0000
+@@ -245,7 +245,7 @@
+   match cf with
+   | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
+   | Pcf_val (_, _, e, _) -> expression ppf tbl e;
+-  | Pcf_virt _ -> ()
++  | Pcf_virt _ | Pcf_valvirt _ -> ()
+   | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
+   | Pcf_cstr _ -> ()
+   | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
+Index: bytecomp/translclass.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
+retrieving revision 1.38
+diff -u -r1.38 translclass.ml
+--- bytecomp/translclass.ml    13 Aug 2005 20:59:37 -0000      1.38
++++ bytecomp/translclass.ml    5 Apr 2006 02:26:00 -0000
+@@ -133,10 +133,10 @@
+                        (fun _ -> lambda_unit) cl
+                    in
+                    (inh_init, lsequence obj_init' obj_init, true)
+-               | Cf_val (_, id, exp) ->
++               | Cf_val (_, id, Some exp, _) ->
+                    (inh_init, lsequence (set_inst_var obj id exp) obj_init,
+                     has_init)
+-               | Cf_meth _ ->
++               | Cf_meth _ | Cf_val _ ->
+                    (inh_init, obj_init, has_init)
+                | Cf_init _ ->
+                    (inh_init, obj_init, true)
+@@ -213,27 +213,17 @@
+   if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
+   if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
+   let ids = Ident.create "ids" in
+-  let i = ref len in
+-  let getter, names, cl_init =
+-    match vals with [] -> "get_method_labels", [], cl_init
+-    | (_,id0)::vals' ->
+-        incr i;
+-        let i = ref (List.length vals) in
+-        "new_methods_variables",
+-        [transl_meth_list (List.map fst vals)],
+-        Llet(Strict, id0, lfield ids 0,
+-           List.fold_right
+-             (fun (name,id) rem ->
+-               decr i;
+-                 Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
+-             vals' cl_init)
++  let i = ref (len + nvals) in
++  let getter, names =
++    if nvals = 0 then "get_method_labels", [] else
++    "new_methods_variables", [transl_meth_list (List.map fst vals)]
+   in
+   Llet(StrictOpt, ids,
+        Lapply (oo_prim getter,
+                [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
+        List.fold_right
+          (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
+-         methl cl_init)
++         (methl @ vals) cl_init)
+ 
+ let output_methods tbl methods lam =
+   match methods with
+@@ -283,8 +273,9 @@
+                     (vals, meths_super cla str.cl_meths meths)
+                     inh_init cl_init msubst top cl in
+                 (inh_init, cl_init, [], values)
+-            | Cf_val (name, id, exp) ->
+-                (inh_init, cl_init, methods, (name, id)::values)
++            | Cf_val (name, id, exp, over) ->
++                let values = if over then values else (name, id) :: values in
++                (inh_init, cl_init, methods, values)
+             | Cf_meth (name, exp) ->
+                 let met_code = msubst true (transl_exp exp) in
+                 let met_code =
+@@ -342,27 +333,24 @@
+         assert (Path.same path path');
+         let lpath = transl_path path in
+           let inh = Ident.create "inh"
+-          and inh_vals = Ident.create "vals"
+-          and inh_meths = Ident.create "meths"
++          and ofs = List.length vals + 1
+           and valids, methids = super in
+           let cl_init =
+             List.fold_left
+               (fun init (nm, id, _) ->
+-                Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths),
++                Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
+                      init))
+               cl_init methids in
+           let cl_init =
+             List.fold_left
+               (fun init (nm, id) ->
+-                Llet(StrictOpt, id, lfield inh_vals (index nm vals), init))
++                Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
+               cl_init valids in
+           (inh_init,
+            Llet (Strict, inh, 
+                Lapply(oo_prim "inherits", narrow_args @
+                       [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
+-                 Llet(StrictOpt, obj_init, lfield inh 0,
+-                 Llet(Alias, inh_vals, lfield inh 1,
+-                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
++                 Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
+       | _ ->
+         let core cl_init =
+             build_class_init cla true super inh_init cl_init msubst top cl
+@@ -397,12 +385,16 @@
+    XXX Il devrait etre peu couteux d'ecrire des classes :
+      class c x y = d e f
+ *)
+-let rec transl_class_rebind obj_init cl =
++let rec transl_class_rebind obj_init cl vf =
+   match cl.cl_desc with
+     Tclass_ident path ->
++      if vf = Concrete then begin
++        try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
++        with Not_found -> raise Exit
++      end;
+       (path, obj_init)
+   | Tclass_fun (pat, _, cl, partial) ->
+-      let path, obj_init = transl_class_rebind obj_init cl in
++      let path, obj_init = transl_class_rebind obj_init cl vf in
+       let build params rem =
+         let param = name_pattern "param" [pat, ()] in
+         Lfunction (Curried, param::params,
+@@ -414,14 +406,14 @@
+          Lfunction (Curried, params, rem) -> build params rem
+        | rem                              -> build [] rem)
+   | Tclass_apply (cl, oexprs) ->
+-      let path, obj_init = transl_class_rebind obj_init cl in
++      let path, obj_init = transl_class_rebind obj_init cl vf in
+       (path, transl_apply obj_init oexprs)
+   | Tclass_let (rec_flag, defs, vals, cl) ->
+-      let path, obj_init = transl_class_rebind obj_init cl in
++      let path, obj_init = transl_class_rebind obj_init cl vf in
+       (path, Translcore.transl_let rec_flag defs obj_init)
+   | Tclass_structure _ -> raise Exit
+   | Tclass_constraint (cl', _, _, _) ->
+-      let path, obj_init = transl_class_rebind obj_init cl' in
++      let path, obj_init = transl_class_rebind obj_init cl' vf in
+       let rec check_constraint = function
+           Tcty_constr(path', _, _) when Path.same path path' -> ()
+         | Tcty_fun (_, _, cty) -> check_constraint cty
+@@ -430,21 +422,21 @@
+       check_constraint cl.cl_type;
+       (path, obj_init)
+ 
+-let rec transl_class_rebind_0 self obj_init cl =
++let rec transl_class_rebind_0 self obj_init cl vf =
+   match cl.cl_desc with
+     Tclass_let (rec_flag, defs, vals, cl) ->
+-      let path, obj_init = transl_class_rebind_0 self obj_init cl in
++      let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
+       (path, Translcore.transl_let rec_flag defs obj_init)
+   | _ ->
+-      let path, obj_init = transl_class_rebind obj_init cl in
++      let path, obj_init = transl_class_rebind obj_init cl vf in
+       (path, lfunction [self] obj_init)
+ 
+-let transl_class_rebind ids cl =
++let transl_class_rebind ids cl vf =
+   try
+     let obj_init = Ident.create "obj_init"
+     and self = Ident.create "self" in
+     let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
+-    let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
++    let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
+     if not (Translcore.check_recursive_lambda ids obj_init') then
+       raise(Error(cl.cl_loc, Illegal_class_expr));
+     let id = (obj_init' = lfunction [self] obj_init0) in
+@@ -592,9 +584,9 @@
+ *)
+ 
+ 
+-let transl_class ids cl_id arity pub_meths cl =
++let transl_class ids cl_id arity pub_meths cl vflag =
+   (* First check if it is not only a rebind *)
+-  let rebind = transl_class_rebind ids cl in
++  let rebind = transl_class_rebind ids cl vflag in
+   if rebind <> lambda_unit then rebind else
+ 
+   (* Prepare for heavy environment handling *)
+@@ -696,9 +688,7 @@
+   (* Simplest case: an object defined at toplevel (ids=[]) *)
+   if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
+ 
+-  let concrete =
+-    ids = [] ||
+-    Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
++  let concrete = (vflag = Concrete)
+   and lclass lam =
+     let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
+     Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
+@@ -800,11 +790,11 @@
+ 
+ (* Wrapper for class compilation *)
+ 
+-let transl_class ids cl_id arity pub_meths cl =
+-  oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
++let transl_class ids cl_id arity pub_meths cl vf =
++  oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf
+ 
+ let () =
+-  transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
++  transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete)
+ 
+ (* Error report *)
+ 
+Index: bytecomp/translclass.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.mli,v
+retrieving revision 1.11
+diff -u -r1.11 translclass.mli
+--- bytecomp/translclass.mli   12 Aug 2004 12:55:11 -0000      1.11
++++ bytecomp/translclass.mli   5 Apr 2006 02:26:00 -0000
+@@ -16,7 +16,8 @@
+ open Lambda
+ 
+ val transl_class :
+-  Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
++  Ident.t list -> Ident.t ->
++  int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;;
+ 
+ type error = Illegal_class_expr | Tags of string * string
+ 
+Index: bytecomp/translmod.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translmod.ml,v
+retrieving revision 1.51
+diff -u -r1.51 translmod.ml
+--- bytecomp/translmod.ml      12 Aug 2004 12:55:11 -0000      1.51
++++ bytecomp/translmod.ml      5 Apr 2006 02:26:00 -0000
+@@ -317,10 +317,10 @@
+   | Tstr_open path :: rem ->
+       transl_structure fields cc rootpath rem
+   | Tstr_class cl_list :: rem ->
+-      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
++      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
+       Lletrec(List.map
+-                (fun (id, arity, meths, cl) ->
+-                  (id, transl_class ids id arity meths cl))
++                (fun (id, arity, meths, cl, vf) ->
++                  (id, transl_class ids id arity meths cl vf))
+                 cl_list,
+               transl_structure (List.rev ids @ fields) cc rootpath rem)
+   | Tstr_cltype cl_list :: rem ->
+@@ -414,11 +414,11 @@
+   | Tstr_open path :: rem ->
+       transl_store subst rem
+   | Tstr_class cl_list :: rem ->
+-      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
++      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
+       let lam =
+         Lletrec(List.map
+-                  (fun (id, arity, meths, cl) ->
+-                     (id, transl_class ids id arity meths cl))
++                  (fun (id, arity, meths, cl, vf) ->
++                     (id, transl_class ids id arity meths cl vf))
+                   cl_list,
+                 store_idents ids) in
+       Lsequence(subst_lambda subst lam,
+@@ -485,7 +485,7 @@
+   | Tstr_modtype(id, decl) :: rem -> defined_idents rem
+   | Tstr_open path :: rem -> defined_idents rem
+   | Tstr_class cl_list :: rem ->
+-      List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem
++      List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
+   | Tstr_cltype cl_list :: rem -> defined_idents rem
+   | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
+ 
+@@ -603,14 +603,14 @@
+   | Tstr_class cl_list ->
+       (* we need to use unique names for the classes because there might
+          be a value named identically *)
+-      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
++      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
+       List.iter set_toplevel_unique_name ids;
+       Lletrec(List.map
+-                (fun (id, arity, meths, cl) ->
+-                   (id, transl_class ids id arity meths cl))
++                (fun (id, arity, meths, cl, vf) ->
++                   (id, transl_class ids id arity meths cl vf))
+                 cl_list,
+               make_sequence
+-                (fun (id, _, _, _) -> toploop_setvalue_id id)
++                (fun (id, _, _, _, _) -> toploop_setvalue_id id)
+                 cl_list)
+   | Tstr_cltype cl_list ->
+       lambda_unit
+Index: driver/main_args.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/driver/main_args.ml,v
+retrieving revision 1.48
+diff -u -r1.48 main_args.ml
+--- driver/main_args.ml        4 Jan 2006 16:55:49 -0000       1.48
++++ driver/main_args.ml        5 Apr 2006 02:26:00 -0000
+@@ -136,11 +136,11 @@
+       \032    E/e enable/disable fragile match\n\
+       \032    F/f enable/disable partially applied function\n\
+       \032    L/l enable/disable labels omitted in application\n\
+-      \032    M/m enable/disable overridden method\n\
++      \032    M/m enable/disable overridden methods\n\
+       \032    P/p enable/disable partial match\n\
+       \032    S/s enable/disable non-unit statement\n\
+       \032    U/u enable/disable unused match case\n\
+-      \032    V/v enable/disable hidden instance variable\n\
++      \032    V/v enable/disable overridden instance variables\n\
+       \032    Y/y enable/disable suspicious unused variables\n\
+       \032    Z/z enable/disable all other unused variables\n\
+       \032    X/x enable/disable all other warnings\n\
+Index: driver/optmain.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/driver/optmain.ml,v
+retrieving revision 1.87
+diff -u -r1.87 optmain.ml
+--- driver/optmain.ml  4 Jan 2006 16:55:49 -0000       1.87
++++ driver/optmain.ml  5 Apr 2006 02:26:00 -0000
+@@ -173,7 +173,7 @@
+          \032    P/p enable/disable partial match\n\
+          \032    S/s enable/disable non-unit statement\n\
+          \032    U/u enable/disable unused match case\n\
+-         \032    V/v enable/disable hidden instance variables\n\
++         \032    V/v enable/disable overridden instance variables\n\
+          \032    Y/y enable/disable suspicious unused variables\n\
+          \032    Z/z enable/disable all other unused variables\n\
+          \032    X/x enable/disable all other warnings\n\
+Index: stdlib/camlinternalOO.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
+retrieving revision 1.14
+diff -u -r1.14 camlinternalOO.ml
+--- stdlib/camlinternalOO.ml   25 Oct 2005 18:34:07 -0000      1.14
++++ stdlib/camlinternalOO.ml   5 Apr 2006 02:26:00 -0000
+@@ -206,7 +206,11 @@
+      (table.methods_by_name, table.methods_by_label, table.hidden_meths,
+       table.vars, virt_meth_labs, vars)
+      :: table.previous_states;
+-  table.vars <- Vars.empty;
++  table.vars <-
++    Vars.fold
++      (fun lab info tvars ->
++        if List.mem lab vars then Vars.add lab info tvars else tvars)
++      table.vars Vars.empty;
+   let by_name = ref Meths.empty in
+   let by_label = ref Labs.empty in
+   List.iter2
+@@ -255,9 +259,11 @@
+   index
+ 
+ let new_variable table name =
+-  let index = new_slot table in
+-  table.vars <- Vars.add name index table.vars;
+-  index
++  try Vars.find name table.vars
++  with Not_found ->
++    let index = new_slot table in
++    table.vars <- Vars.add name index table.vars;
++    index
+ 
+ let to_array arr =
+   if arr = Obj.magic 0 then [||] else arr
+@@ -265,16 +271,17 @@
+ let new_methods_variables table meths vals =
+   let meths = to_array meths in
+   let nmeths = Array.length meths and nvals = Array.length vals in
+-  let index = new_variable table vals.(0) in
+-  let res = Array.create (nmeths + 1) index in
+-  for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done;
++  let res = Array.create (nmeths + nvals) 0 in
+   for i = 0 to nmeths - 1 do
+-    res.(i+1) <- get_method_label table meths.(i)
++    res.(i) <- get_method_label table meths.(i)
++  done;
++  for i = 0 to nvals - 1 do
++    res.(i+nmeths) <- new_variable table vals.(i)
+   done;
+   res
+ 
+ let get_variable table name =
+-  Vars.find name table.vars
++  try Vars.find name table.vars with Not_found -> assert false
+ 
+ let get_variables table names =
+   Array.map (get_variable table) names
+@@ -315,9 +322,12 @@
+   let init =
+     if top then super cla env else Obj.repr (super cla) in
+   widen cla;
+-  (init, Array.map (get_variable cla) (to_array vals),
+-   Array.map (fun nm -> get_method cla (get_method_label cla nm))
+-     (to_array concr_meths))
++  Array.concat
++    [[| repr init |];
++     magic (Array.map (get_variable cla) (to_array vals) : int array);
++     Array.map
++       (fun nm -> repr (get_method cla (get_method_label cla nm) : closure))
++       (to_array concr_meths) ]
+ 
+ let make_class pub_meths class_init =
+   let table = create_table pub_meths in
+Index: stdlib/camlinternalOO.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
+retrieving revision 1.9
+diff -u -r1.9 camlinternalOO.mli
+--- stdlib/camlinternalOO.mli  25 Oct 2005 18:34:07 -0000      1.9
++++ stdlib/camlinternalOO.mli  5 Apr 2006 02:26:00 -0000
+@@ -46,8 +46,7 @@
+ val init_class : table -> unit
+ val inherits :
+     table -> string array -> string array -> string array ->
+-    (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
+-    (Obj.t * int array * closure array)
++    (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array
+ val make_class :
+     string array -> (table -> Obj.t -> t) ->
+     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
+@@ -79,6 +78,7 @@
+ 
+ (** {6 Builtins to reduce code size} *)
+ 
++(*
+ val get_const : t -> closure
+ val get_var : int -> closure
+ val get_env : int -> int -> closure
+@@ -103,6 +103,7 @@
+ val send_var : tag -> int -> int -> closure
+ val send_env : tag -> int -> int -> int -> closure
+ val send_meth : tag -> label -> int -> closure
++*)
+ 
+ type impl =
+     GetConst
+Index: stdlib/sys.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/stdlib/sys.ml,v
+retrieving revision 1.142
+diff -u -r1.142 sys.ml
+--- stdlib/sys.ml      22 Mar 2006 12:39:39 -0000      1.142
++++ stdlib/sys.ml      5 Apr 2006 02:26:00 -0000
+@@ -78,4 +78,4 @@
+ 
+ (* OCaml version string, must be in the format described in sys.mli. *)
+ 
+-let ocaml_version = "3.10+dev4 (2006-03-22)";;
++let ocaml_version = "3.10+dev5 (2006-04-05)";;
+Index: tools/depend.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/tools/depend.ml,v
+retrieving revision 1.9
+diff -u -r1.9 depend.ml
+--- tools/depend.ml    23 Mar 2005 03:08:37 -0000      1.9
++++ tools/depend.ml    5 Apr 2006 02:26:00 -0000
+@@ -87,7 +87,7 @@
+ 
+ and add_class_type_field bv = function
+     Pctf_inher cty -> add_class_type bv cty
+-  | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty
++  | Pctf_val(_, _, _, ty, _) -> add_type bv ty
+   | Pctf_virt(_, _, ty, _) -> add_type bv ty
+   | Pctf_meth(_, _, ty, _) -> add_type bv ty
+   | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
+@@ -280,6 +280,7 @@
+ and add_class_field bv = function
+     Pcf_inher(ce, _) -> add_class_expr bv ce
+   | Pcf_val(_, _, e, _) -> add_expr bv e
++  | Pcf_valvirt(_, _, ty, _)
+   | Pcf_virt(_, _, ty, _) -> add_type bv ty
+   | Pcf_meth(_, _, e, _) -> add_expr bv e
+   | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
+Index: tools/ocamlprof.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/tools/ocamlprof.ml,v
+retrieving revision 1.38
+diff -u -r1.38 ocamlprof.ml
+--- tools/ocamlprof.ml 24 Mar 2005 17:20:54 -0000      1.38
++++ tools/ocamlprof.ml 5 Apr 2006 02:26:00 -0000
+@@ -328,7 +328,7 @@
+       rewrite_patexp_list iflag spat_sexp_list
+   | Pcf_init sexp ->
+       rewrite_exp iflag sexp
+-  | Pcf_virt _ | Pcf_cstr _  -> ()
++  | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _  -> ()
+ 
+ and rewrite_class_expr iflag cexpr =
+   match cexpr.pcl_desc with
+Index: otherlibs/labltk/browser/searchpos.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/otherlibs/labltk/browser/searchpos.ml,v
+retrieving revision 1.48
+diff -u -r1.48 searchpos.ml
+--- otherlibs/labltk/browser/searchpos.ml      23 Mar 2005 03:08:37 -0000      1.48
++++ otherlibs/labltk/browser/searchpos.ml      5 Apr 2006 02:26:01 -0000
+@@ -141,9 +141,8 @@
+         List.iter cfl ~f:
+           begin function
+               Pctf_inher cty -> search_pos_class_type cty ~pos ~env
+-            | Pctf_val (_, _, Some ty, loc) ->
++            | Pctf_val (_, _, _, ty, loc) ->
+                 if in_loc loc ~pos then search_pos_type ty ~pos ~env
+-            | Pctf_val _ -> ()
+             | Pctf_virt (_, _, ty, loc) ->
+                 if in_loc loc ~pos then search_pos_type ty ~pos ~env
+             | Pctf_meth (_, _, ty, loc) ->
+@@ -675,7 +674,7 @@
+   | Tstr_modtype _ -> ()
+   | Tstr_open _ -> ()
+   | Tstr_class l ->
+-      List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos)
++      List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos)
+   | Tstr_cltype _ -> ()
+   | Tstr_include (m, _) -> search_pos_module_expr m ~pos
+   end
+@@ -685,7 +684,8 @@
+     begin function
+         Cf_inher (cl, _, _) ->
+           search_pos_class_expr cl ~pos
+-      | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
++      | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
++      | Cf_val _ -> ()
+       | Cf_meth (_, exp) -> search_pos_expr exp ~pos
+       | Cf_let (_, pel, iel) ->
+           List.iter pel ~f:
+Index: ocamldoc/Makefile
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/Makefile,v
+retrieving revision 1.61
+diff -u -r1.61 Makefile
+--- ocamldoc/Makefile  4 Jan 2006 16:55:49 -0000       1.61
++++ ocamldoc/Makefile  5 Apr 2006 02:26:01 -0000
+@@ -31,7 +31,7 @@
+ MKDIR=mkdir -p
+ CP=cp -f
+ OCAMLDOC=ocamldoc
+-OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
++OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
+ OCAMLDOC_OPT=$(OCAMLDOC).opt
+ OCAMLDOC_LIBCMA=odoc_info.cma
+ OCAMLDOC_LIBCMI=odoc_info.cmi
+@@ -188,12 +188,12 @@
+       ../otherlibs/num/num.mli
+ 
+ all: exe lib
+-      $(MAKE) manpages
+ 
+ exe: $(OCAMLDOC)
+ lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
+ 
+ opt.opt: exeopt libopt
++      $(MAKE) manpages
+ exeopt: $(OCAMLDOC_OPT)
+ libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
+ debug:
+Index: ocamldoc/odoc_ast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_ast.ml,v
+retrieving revision 1.27
+diff -u -r1.27 odoc_ast.ml
+--- ocamldoc/odoc_ast.ml       4 Jan 2006 16:55:49 -0000       1.27
++++ ocamldoc/odoc_ast.ml       5 Apr 2006 02:26:01 -0000
+@@ -88,7 +88,7 @@
+             ident_type_decl_list
+       | Typedtree.Tstr_class info_list ->
+           List.iter
+-            (fun ((id,_,_,_) as ci) ->
++            (fun ((id,_,_,_,_) as ci) ->
+               Hashtbl.add table (C (Name.from_ident id))
+                 (Typedtree.Tstr_class [ci]))
+             info_list
+@@ -146,7 +146,7 @@
+ 
+     let search_class_exp table name =
+       match Hashtbl.find table (C name) with
+-      | (Typedtree.Tstr_class [(_,_,_,ce)]) ->
++      | (Typedtree.Tstr_class [(_,_,_,ce,_)]) ->
+           (
+            try
+              let type_decl = search_type_declaration table name in
+@@ -184,7 +184,7 @@
+       let rec iter = function
+         | [] ->
+             raise Not_found
+-        | Typedtree.Cf_val (_, ident, exp) :: q
++        | Typedtree.Cf_val (_, ident, Some exp, _) :: q
+           when Name.from_ident ident = name ->
+             exp.Typedtree.exp_type
+         | _ :: q ->
+@@ -523,7 +523,8 @@
+               p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
+               q
+ 
+-        | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
++        | (Parsetree.Pcf_val (label, mutable_flag, _, loc) |
++           Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q ->
+             let complete_name = Name.concat current_class_name label in
+             let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+             let type_exp =
+Index: ocamldoc/odoc_sig.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_sig.ml,v
+retrieving revision 1.37
+diff -u -r1.37 odoc_sig.ml
+--- ocamldoc/odoc_sig.ml       4 Jan 2006 16:55:50 -0000       1.37
++++ ocamldoc/odoc_sig.ml       5 Apr 2006 02:26:01 -0000
+@@ -107,7 +107,7 @@
+       | _ -> assert false
+ 
+     let search_attribute_type name class_sig =
+-      let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
++      let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
+       type_expr
+ 
+     let search_method_type name class_sig =
+@@ -269,7 +269,7 @@
+           [] -> pos_limit
+         | ele2 :: _ ->
+             match ele2 with
+-              Parsetree.Pctf_val (_, _, _, loc)
++              Parsetree.Pctf_val (_, _, _, _, loc)
+             | Parsetree.Pctf_virt (_, _, _, loc)
+             | Parsetree.Pctf_meth (_, _, _, loc)
+             | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum
+@@ -330,7 +330,7 @@
+             in
+             ([], ele_comments)
+ 
+-        | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q ->
++        | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q ->
+             (* of (string * mutable_flag * core_type option * Location.t)*)
+             let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+             let complete_name = Name.concat current_class_name name in
+Index: camlp4/camlp4/ast2pt.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/ast2pt.ml,v
+retrieving revision 1.36
+diff -u -r1.36 ast2pt.ml
+--- camlp4/camlp4/ast2pt.ml    29 Jun 2005 04:11:26 -0000      1.36
++++ camlp4/camlp4/ast2pt.ml    5 Apr 2006 02:26:01 -0000
+@@ -244,6 +244,7 @@
+ ;
+ value mkmutable m = if m then Mutable else Immutable;
+ value mkprivate m = if m then Private else Public;
++value mkvirtual m = if m then Virtual else Concrete;
+ value mktrecord (loc, n, m, t) =
+   (n, mkmutable m, ctyp (mkpolytype t), mkloc loc);
+ value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc);
+@@ -862,8 +863,8 @@
+   | CgInh loc ct -> [Pctf_inher (class_type ct) :: l]
+   | CgMth loc s pf t ->
+       [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l]
+-  | CgVal loc s b t ->
+-      [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l]
++  | CgVal loc s b v t ->
++      [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l]
+   | CgVir loc s b t ->
+       [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
+ and class_expr =
+@@ -907,7 +908,9 @@
+       [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
+   | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
+   | CrVir loc s b t ->
+-      [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
++      [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l]
++  | CrVvr loc s b t ->
++      [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] ]
+ ;
+ 
+ value interf ast = List.fold_right sig_item ast [];
+Index: camlp4/camlp4/mLast.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/mLast.mli,v
+retrieving revision 1.18
+diff -u -r1.18 mLast.mli
+--- camlp4/camlp4/mLast.mli    29 Jun 2005 04:11:26 -0000      1.18
++++ camlp4/camlp4/mLast.mli    5 Apr 2006 02:26:01 -0000
+@@ -180,7 +180,7 @@
+   | CgDcl of loc and list class_sig_item
+   | CgInh of loc and class_type
+   | CgMth of loc and string and bool and ctyp
+-  | CgVal of loc and string and bool and ctyp
++  | CgVal of loc and string and bool and bool and ctyp
+   | CgVir of loc and string and bool and ctyp ]
+ and class_expr =
+   [ CeApp of loc and class_expr and expr
+@@ -196,7 +196,8 @@
+   | CrIni of loc and expr
+   | CrMth of loc and string and bool and expr and option ctyp
+   | CrVal of loc and string and bool and expr
+-  | CrVir of loc and string and bool and ctyp ]
++  | CrVir of loc and string and bool and ctyp
++  | CrVvr of loc and string and bool and ctyp ]
+ ;
+ 
+ external loc_of_ctyp : ctyp -> loc = "%field0";
+Index: camlp4/camlp4/reloc.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/reloc.ml,v
+retrieving revision 1.18
+diff -u -r1.18 reloc.ml
+--- camlp4/camlp4/reloc.ml     29 Jun 2005 04:11:26 -0000      1.18
++++ camlp4/camlp4/reloc.ml     5 Apr 2006 02:26:01 -0000
+@@ -350,7 +350,7 @@
+     | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1)
+     | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1)
+     | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3)
+-    | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3)
++    | CgVal loc x1 x2 x3 x4 -> let nloc = floc loc in CgVal nloc x1 x2 x3 (ctyp floc sh x4)
+     | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ]
+ and class_expr floc sh =
+   self where rec self =
+@@ -377,5 +377,6 @@
+     | CrMth loc x1 x2 x3 x4 ->
+         let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4)
+     | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3)
+-    | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ]
++    | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3)
++    | CrVvr loc x1 x2 x3 -> let nloc = floc loc in CrVvr nloc x1 x2 (ctyp floc sh x3) ]
+ ;
+Index: camlp4/etc/pa_o.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pa_o.ml,v
+retrieving revision 1.66
+diff -u -r1.66 pa_o.ml
+--- camlp4/etc/pa_o.ml 29 Jun 2005 04:11:26 -0000      1.66
++++ camlp4/etc/pa_o.ml 5 Apr 2006 02:26:01 -0000
+@@ -1037,8 +1037,14 @@
+   class_str_item:
+     [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
+           <:class_str_item< inherit $ce$ $opt:pb$ >>
+-      | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
+-          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
++      | "val"; "mutable"; lab = label; e = cvalue_binding ->
++          <:class_str_item< value mutable $lab$ = $e$ >>
++      | "val"; lab = label; e = cvalue_binding ->
++          <:class_str_item< value $lab$ = $e$ >>
++      | "val"; "mutable"; "virtual"; lab = label; ":"; t = ctyp ->
++          <:class_str_item< value virtual mutable $lab$ : $t$ >>
++      | "val"; "virtual"; mf = OPT "mutable"; lab = label; ":"; t = ctyp ->
++          <:class_str_item< value virtual $opt:o2b mf$ $lab$ : $t$ >>
+       | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
+           <:class_str_item< method virtual private $l$ : $t$ >>
+       | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
+@@ -1087,8 +1093,9 @@
+   ;
+   class_sig_item:
+     [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
+-      | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
+-          <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
++      | "val"; mf = OPT "mutable"; vf = OPT "virtual";
++        l = label; ":"; t = ctyp ->
++          <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
+       | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
+           <:class_sig_item< method virtual private $l$ : $t$ >>
+       | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
+Index: camlp4/etc/pr_o.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pr_o.ml,v
+retrieving revision 1.51
+diff -u -r1.51 pr_o.ml
+--- camlp4/etc/pr_o.ml 5 Jan 2006 10:44:29 -0000       1.51
++++ camlp4/etc/pr_o.ml 5 Apr 2006 02:26:01 -0000
+@@ -1768,10 +1768,11 @@
+                   [: `S LR "method"; private_flag pf; `label lab;
+                      `S LR ":" :];
+                `ctyp t "" k :]
+-      | MLast.CgVal _ lab mf t ->
++      | MLast.CgVal _ lab mf vf t ->
+           fun curr next dg k ->
+             [: `HVbox
+-                  [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :];
++                  [: `S LR "val"; mutable_flag mf; virtual_flag vf;
++                     `label lab; `S LR ":" :];
+                `ctyp t "" k :]
+       | MLast.CgVir _ lab pf t ->
+           fun curr next dg k ->
+Index: camlp4/meta/pa_r.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/pa_r.ml,v
+retrieving revision 1.64
+diff -u -r1.64 pa_r.ml
+--- camlp4/meta/pa_r.ml        29 Jun 2005 04:11:26 -0000      1.64
++++ camlp4/meta/pa_r.ml        5 Apr 2006 02:26:01 -0000
+@@ -658,7 +658,9 @@
+       | "inherit"; ce = class_expr; pb = OPT as_lident ->
+           <:class_str_item< inherit $ce$ $opt:pb$ >>
+       | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
+-          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
++          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> 
++      | "value"; "virtual"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
++          <:class_str_item< value virtual $opt:o2b mf$ $l$ : $t$ >>
+       | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
+           <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
+       | "method"; pf = OPT "private"; l = label; topt = OPT polyt;
+@@ -701,8 +703,9 @@
+     [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
+           <:class_sig_item< declare $list:st$ end >>
+       | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >>
+-      | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
+-          <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
++      | "value"; mf = OPT "mutable"; vf = OPT "virtual";
++        l = label; ":"; t = ctyp ->
++          <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
+       | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
+           <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
+       | "method"; pf = OPT "private"; l = label; ":"; t = ctyp ->
+Index: camlp4/meta/q_MLast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/q_MLast.ml,v
+retrieving revision 1.60
+diff -u -r1.60 q_MLast.ml
+--- camlp4/meta/q_MLast.ml     29 Jun 2005 04:11:26 -0000      1.60
++++ camlp4/meta/q_MLast.ml     5 Apr 2006 02:26:01 -0000
+@@ -947,6 +947,8 @@
+           Qast.Node "CrDcl" [Qast.Loc; st]
+       | "inherit"; ce = class_expr; pb = SOPT as_lident ->
+           Qast.Node "CrInh" [Qast.Loc; ce; pb]
++      | "value"; "virtual"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
++          Qast.Node "CrVvr" [Qast.Loc; l; o2b mf; t]
+       | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding ->
+           Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e]
+       | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
+@@ -992,8 +994,9 @@
+     [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
+           Qast.Node "CgDcl" [Qast.Loc; st]
+       | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
+-      | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
+-          Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t]
++      | "value"; mf = SOPT "mutable"; vf = SOPT "virtual";
++        l = label; ":"; t = ctyp ->
++          Qast.Node "CgVal" [Qast.Loc; l; o2b mf; o2b vf; t]
+       | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
+           Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t]
+       | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
+Index: camlp4/ocaml_src/camlp4/ast2pt.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/ast2pt.ml,v
+retrieving revision 1.36
+diff -u -r1.36 ast2pt.ml
+--- camlp4/ocaml_src/camlp4/ast2pt.ml  29 Jun 2005 04:11:26 -0000      1.36
++++ camlp4/ocaml_src/camlp4/ast2pt.ml  5 Apr 2006 02:26:01 -0000
+@@ -227,6 +227,7 @@
+ ;;
+ let mkmutable m = if m then Mutable else Immutable;;
+ let mkprivate m = if m then Private else Public;;
++let mkvirtual m = if m then Virtual else Concrete;;
+ let mktrecord (loc, n, m, t) =
+   n, mkmutable m, ctyp (mkpolytype t), mkloc loc
+ ;;
+@@ -878,8 +879,8 @@
+   | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l
+   | CgMth (loc, s, pf, t) ->
+       Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l
+-  | CgVal (loc, s, b, t) ->
+-      Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l
++  | CgVal (loc, s, b, v, t) ->
++      Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l
+   | CgVir (loc, s, b, t) ->
+       Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
+ and class_expr =
+@@ -923,6 +924,8 @@
+   | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l
+   | CrVir (loc, s, b, t) ->
+       Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
++  | CrVvr (loc, s, b, t) ->
++      Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l
+ ;;
+ 
+ let interf ast = List.fold_right sig_item ast [];;
+Index: camlp4/ocaml_src/camlp4/mLast.mli
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/mLast.mli,v
+retrieving revision 1.20
+diff -u -r1.20 mLast.mli
+--- camlp4/ocaml_src/camlp4/mLast.mli  29 Jun 2005 04:11:26 -0000      1.20
++++ camlp4/ocaml_src/camlp4/mLast.mli  5 Apr 2006 02:26:01 -0000
+@@ -180,7 +180,7 @@
+   | CgDcl of loc * class_sig_item list
+   | CgInh of loc * class_type
+   | CgMth of loc * string * bool * ctyp
+-  | CgVal of loc * string * bool * ctyp
++  | CgVal of loc * string * bool * bool * ctyp
+   | CgVir of loc * string * bool * ctyp
+ and class_expr =
+     CeApp of loc * class_expr * expr
+@@ -197,6 +197,7 @@
+   | CrMth of loc * string * bool * expr * ctyp option
+   | CrVal of loc * string * bool * expr
+   | CrVir of loc * string * bool * ctyp
++  | CrVvr of loc * string * bool * ctyp
+ ;;
+ 
+ external loc_of_ctyp : ctyp -> loc = "%field0";;
+Index: camlp4/ocaml_src/camlp4/reloc.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/reloc.ml,v
+retrieving revision 1.20
+diff -u -r1.20 reloc.ml
+--- camlp4/ocaml_src/camlp4/reloc.ml   29 Jun 2005 04:11:26 -0000      1.20
++++ camlp4/ocaml_src/camlp4/reloc.ml   5 Apr 2006 02:26:01 -0000
+@@ -430,8 +430,8 @@
+         let nloc = floc loc in CgInh (nloc, class_type floc sh x1)
+     | CgMth (loc, x1, x2, x3) ->
+         let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3)
+-    | CgVal (loc, x1, x2, x3) ->
+-        let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3)
++    | CgVal (loc, x1, x2, x3, x4) ->
++        let nloc = floc loc in CgVal (nloc, x1, x2, x3, ctyp floc sh x4)
+     | CgVir (loc, x1, x2, x3) ->
+         let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3)
+   in
+@@ -478,6 +478,8 @@
+         let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3)
+     | CrVir (loc, x1, x2, x3) ->
+         let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3)
++    | CrVvr (loc, x1, x2, x3) ->
++        let nloc = floc loc in CrVvr (nloc, x1, x2, ctyp floc sh x3)
+   in
+   self
+ ;;
+Index: camlp4/ocaml_src/meta/pa_r.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/pa_r.ml,v
+retrieving revision 1.59
+diff -u -r1.59 pa_r.ml
+--- camlp4/ocaml_src/meta/pa_r.ml      29 Jun 2005 04:11:26 -0000      1.59
++++ camlp4/ocaml_src/meta/pa_r.ml      5 Apr 2006 02:26:01 -0000
+@@ -2161,6 +2161,15 @@
+         (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
+            (_loc : Lexing.position * Lexing.position) ->
+            (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item));
++      [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
++       Gramext.Sopt (Gramext.Stoken ("", "mutable"));
++       Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
++       Gramext.Stoken ("", ":");
++       Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
++      Gramext.action
++        (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ _
++           (_loc : Lexing.position * Lexing.position) ->
++           (MLast.CrVvr (_loc, l, o2b mf, t) : 'class_str_item));
+       [Gramext.Stoken ("", "value");
+        Gramext.Sopt (Gramext.Stoken ("", "mutable"));
+        Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
+@@ -2338,13 +2347,15 @@
+            (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item));
+       [Gramext.Stoken ("", "value");
+        Gramext.Sopt (Gramext.Stoken ("", "mutable"));
++       Gramext.Sopt (Gramext.Stoken ("", "virtual"));
+        Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
+        Gramext.Stoken ("", ":");
+        Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
+       Gramext.action
+-        (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _
++        (fun (t : 'ctyp) _ (l : 'label) (vf : string option)
++           (mf : string option) _
+            (_loc : Lexing.position * Lexing.position) ->
+-           (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item));
++           (MLast.CgVal (_loc, l, o2b mf, o2b vf, t) : 'class_sig_item));
+       [Gramext.Stoken ("", "inherit");
+        Gramext.Snterm
+          (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
+Index: camlp4/ocaml_src/meta/q_MLast.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/q_MLast.ml,v
+retrieving revision 1.65
+diff -u -r1.65 q_MLast.ml
+--- camlp4/ocaml_src/meta/q_MLast.ml   12 Jan 2006 08:54:21 -0000      1.65
++++ camlp4/ocaml_src/meta/q_MLast.ml   5 Apr 2006 02:26:01 -0000
+@@ -3152,9 +3152,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__17))])],
++                      (Qast.Str x : 'e__18))])],
+           Gramext.action
+-            (fun (a : 'e__17 option)
++            (fun (a : 'e__18 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3191,9 +3191,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__16))])],
++                      (Qast.Str x : 'e__17))])],
+           Gramext.action
+-            (fun (a : 'e__16 option)
++            (fun (a : 'e__17 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3216,9 +3216,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__15))])],
++                      (Qast.Str x : 'e__16))])],
+           Gramext.action
+-            (fun (a : 'e__15 option)
++            (fun (a : 'e__16 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3235,6 +3235,31 @@
+            (_loc : Lexing.position * Lexing.position) ->
+            (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) :
+             'class_str_item));
++      [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
++       Gramext.srules
++         [[Gramext.Sopt
++             (Gramext.srules
++                [[Gramext.Stoken ("", "mutable")],
++                 Gramext.action
++                   (fun (x : string)
++                      (_loc : Lexing.position * Lexing.position) ->
++                      (Qast.Str x : 'e__15))])],
++          Gramext.action
++            (fun (a : 'e__15 option)
++               (_loc : Lexing.position * Lexing.position) ->
++               (Qast.Option a : 'a_opt));
++          [Gramext.Snterm
++             (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
++          Gramext.action
++            (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
++               (a : 'a_opt))];
++       Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
++       Gramext.Stoken ("", ":");
++       Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
++      Gramext.action
++        (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ _
++           (_loc : Lexing.position * Lexing.position) ->
++           (Qast.Node ("CrVvr", [Qast.Loc; l; o2b mf; t]) : 'class_str_item));
+       [Gramext.Stoken ("", "inherit");
+        Gramext.Snterm
+          (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
+@@ -3366,9 +3391,9 @@
+                  Gramext.action
+                    (fun _ (csf : 'class_sig_item)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (csf : 'e__18))])],
++                      (csf : 'e__19))])],
+           Gramext.action
+-            (fun (a : 'e__18 list)
++            (fun (a : 'e__19 list)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.List a : 'a_list));
+           [Gramext.Snterm
+@@ -3446,9 +3471,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__22))])],
++                      (Qast.Str x : 'e__24))])],
+           Gramext.action
+-            (fun (a : 'e__22 option)
++            (fun (a : 'e__24 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3471,9 +3496,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__21))])],
++                      (Qast.Str x : 'e__23))])],
+           Gramext.action
+-            (fun (a : 'e__21 option)
++            (fun (a : 'e__23 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3496,9 +3521,26 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__20))])],
++                      (Qast.Str x : 'e__21))])],
+           Gramext.action
+-            (fun (a : 'e__20 option)
++            (fun (a : 'e__21 option)
++               (_loc : Lexing.position * Lexing.position) ->
++               (Qast.Option a : 'a_opt));
++          [Gramext.Snterm
++             (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
++          Gramext.action
++            (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
++               (a : 'a_opt))];
++       Gramext.srules
++         [[Gramext.Sopt
++             (Gramext.srules
++                [[Gramext.Stoken ("", "virtual")],
++                 Gramext.action
++                   (fun (x : string)
++                      (_loc : Lexing.position * Lexing.position) ->
++                      (Qast.Str x : 'e__22))])],
++          Gramext.action
++            (fun (a : 'e__22 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3510,9 +3552,10 @@
+        Gramext.Stoken ("", ":");
+        Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
+       Gramext.action
+-        (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _
++        (fun (t : 'ctyp) _ (l : 'label) (vf : 'a_opt) (mf : 'a_opt) _
+            (_loc : Lexing.position * Lexing.position) ->
+-           (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item));
++           (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; o2b vf; t]) :
++            'class_sig_item));
+       [Gramext.Stoken ("", "inherit");
+        Gramext.Snterm
+          (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
+@@ -3531,9 +3574,9 @@
+                  Gramext.action
+                    (fun _ (s : 'class_sig_item)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (s : 'e__19))])],
++                      (s : 'e__20))])],
+           Gramext.action
+-            (fun (a : 'e__19 list)
++            (fun (a : 'e__20 list)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.List a : 'a_list));
+           [Gramext.Snterm
+@@ -3556,9 +3599,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__23))])],
++                      (Qast.Str x : 'e__25))])],
+           Gramext.action
+-            (fun (a : 'e__23 option)
++            (fun (a : 'e__25 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3593,9 +3636,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__24))])],
++                      (Qast.Str x : 'e__26))])],
+           Gramext.action
+-            (fun (a : 'e__24 option)
++            (fun (a : 'e__26 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3713,9 +3756,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__25))])],
++                      (Qast.Str x : 'e__27))])],
+           Gramext.action
+-            (fun (a : 'e__25 option)
++            (fun (a : 'e__27 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -3922,9 +3965,9 @@
+                  Gramext.action
+                    (fun (x : string)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (Qast.Str x : 'e__26))])],
++                      (Qast.Str x : 'e__28))])],
+           Gramext.action
+-            (fun (a : 'e__26 option)
++            (fun (a : 'e__28 option)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.Option a : 'a_opt));
+           [Gramext.Snterm
+@@ -4390,9 +4433,9 @@
+                  Gramext.action
+                    (fun _ (e : 'expr)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (e : 'e__29))])],
++                      (e : 'e__31))])],
+           Gramext.action
+-            (fun (a : 'e__29 list)
++            (fun (a : 'e__31 list)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.List a : 'a_list));
+           [Gramext.Snterm
+@@ -4425,9 +4468,9 @@
+                  Gramext.action
+                    (fun _ (e : 'expr)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (e : 'e__28))])],
++                      (e : 'e__30))])],
+           Gramext.action
+-            (fun (a : 'e__28 list)
++            (fun (a : 'e__30 list)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.List a : 'a_list));
+           [Gramext.Snterm
+@@ -4454,9 +4497,9 @@
+                  Gramext.action
+                    (fun _ (e : 'expr)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (e : 'e__27))])],
++                      (e : 'e__29))])],
+           Gramext.action
+-            (fun (a : 'e__27 list)
++            (fun (a : 'e__29 list)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.List a : 'a_list));
+           [Gramext.Snterm
+@@ -4547,9 +4590,9 @@
+                  Gramext.action
+                    (fun _ (cf : 'class_str_item)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (cf : 'e__30))])],
++                      (cf : 'e__32))])],
+           Gramext.action
+-            (fun (a : 'e__30 list)
++            (fun (a : 'e__32 list)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.List a : 'a_list));
+           [Gramext.Snterm
+@@ -4592,9 +4635,9 @@
+                  Gramext.action
+                    (fun _ (csf : 'class_sig_item)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (csf : 'e__32))])],
++                      (csf : 'e__34))])],
+           Gramext.action
+-            (fun (a : 'e__32 list)
++            (fun (a : 'e__34 list)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.List a : 'a_list));
+           [Gramext.Snterm
+@@ -4623,9 +4666,9 @@
+                  Gramext.action
+                    (fun _ (csf : 'class_sig_item)
+                       (_loc : Lexing.position * Lexing.position) ->
+-                      (csf : 'e__31))])],
++                      (csf : 'e__33))])],
+           Gramext.action
+-            (fun (a : 'e__31 list)
++            (fun (a : 'e__33 list)
+                (_loc : Lexing.position * Lexing.position) ->
+                (Qast.List a : 'a_list));
+           [Gramext.Snterm
+Index: camlp4/top/rprint.ml
+===================================================================
+RCS file: /net/yquem/devel/caml/repository/csl/camlp4/top/rprint.ml,v
+retrieving revision 1.18
+diff -u -r1.18 rprint.ml
+--- camlp4/top/rprint.ml       29 Jun 2005 04:11:26 -0000      1.18
++++ camlp4/top/rprint.ml       5 Apr 2006 02:26:01 -0000
+@@ -288,8 +288,9 @@
+       fprintf ppf "@[<2>method %s%s%s :@ %a;@]"
+         (if priv then "private " else "") (if virt then "virtual " else "")
+         name Toploop.print_out_type.val ty
+-  | Ocsg_value name mut ty ->
+-      fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "")
++  | Ocsg_value name mut virt ty ->
++      fprintf ppf "@[<2>value %s%s%s :@ %a;@]"
++        (if mut then "mutable " else "") (if virt then "virtual " else "")
+         name Toploop.print_out_type.val ty ]
+ ;
+ 

diff --git a/experimental/garrigue/variable-names-Tvar.diffs b/experimental/garrigue/variable-names-Tvar.diffs
new file mode 100644 (file)
index 0000000..99ff6a2
--- /dev/null
+++ b/experimental/garrigue/variable-names-Tvar.diffs
@@ -0,0 +1,1656 @@
+Index: VERSION
+===================================================================
+--- VERSION    (リビジョン 11207)
++++ VERSION    (作業コピー)
+@@ -1,4 +1,4 @@
+-3.13.0+dev6 (2011-07-29)
++3.13.0+dev7 (2011-09-22)
+ 
+ # The version string is the first line of this file.
+ # It must be in the format described in stdlib/sys.mli
+Index: typing/typemod.ml
+===================================================================
+--- typing/typemod.ml  (リビジョン 11207)
++++ typing/typemod.ml  (作業コピー)
+@@ -764,7 +764,7 @@
+               Location.prerr_warning smod.pmod_loc
+                 (Warnings.Not_principal "this module unpacking");
+             modtype_of_package env smod.pmod_loc p nl tl
+-        | {desc = Tvar} ->
++        | {desc = Tvar _} ->
+             raise (Typecore.Error
+                      (smod.pmod_loc, Typecore.Cannot_infer_signature))
+         | _ ->
+Index: typing/typetexp.ml
+===================================================================
+--- typing/typetexp.ml (リビジョン 11207)
++++ typing/typetexp.ml (作業コピー)
+@@ -150,7 +150,7 @@
+     if strict then raise Already_bound;
+     v
+   with Not_found ->
+-    let v = new_global_var() in
++    let v = new_global_var ~name () in
+     type_variables := Tbl.add name v !type_variables;
+     v
+ 
+@@ -165,8 +165,8 @@
+     Tpoly _ -> ty
+   | _ -> Ctype.newty (Tpoly (ty, []))
+ 
+-let new_pre_univar () =
+-  let v = newvar () in pre_univars := v :: !pre_univars; v
++let new_pre_univar ?name () =
++  let v = newvar ?name () in pre_univars := v :: !pre_univars; v
+ 
+ let rec swap_list = function
+     x :: y :: l -> y :: x :: swap_list l
+@@ -190,7 +190,8 @@
+         instance (fst(Tbl.find name !used_variables))
+       with Not_found ->
+         let v =
+-          if policy = Univars then new_pre_univar () else newvar () in
++          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
++        in
+         used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables;
+         v
+       end
+@@ -333,7 +334,14 @@
+             end_def ();
+             generalize_structure t;
+           end;
+-          instance t
++          let t = instance t in
++          let px = Btype.proxy t in
++          begin match px.desc with
++          | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
++          | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias)
++          | _ -> ()
++          end;
++          t
+       end
+   | Ptyp_variant(fields, closed, present) ->
+       let name = ref None in
+@@ -388,7 +396,7 @@
+               {desc=Tvariant row}, _ when Btype.static_row row ->
+                 let row = Btype.row_repr row in
+                 row.row_fields
+-            | {desc=Tvar}, Some(p, _) ->
++            | {desc=Tvar _}, Some(p, _) ->
+                 raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p))
+             | _ ->
+                 raise(Error(sty.ptyp_loc, Not_a_variant ty))
+@@ -431,7 +439,7 @@
+       newty (Tvariant row)
+   | Ptyp_poly(vars, st) ->
+       begin_def();
+-      let new_univars = List.map (fun name -> name, newvar()) vars in
++      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
+       let old_univars = !univars in
+       univars := new_univars @ !univars;
+       let ty = transl_type env policy st in
+@@ -443,10 +451,12 @@
+           (fun tyl (name, ty1) ->
+             let v = Btype.proxy ty1 in
+             if deep_occur v ty then begin
+-              if v.level <> Btype.generic_level || v.desc <> Tvar then
+-                raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)));
+-              v.desc <- Tunivar;
+-              v :: tyl
++              match v.desc with
++                Tvar name when v.level = Btype.generic_level ->
++                  v.desc <- Tunivar name;
++                  v :: tyl
++              | _ ->
++                raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)))
+             end else tyl)
+           [] new_univars
+       in
+@@ -483,7 +493,7 @@
+     match ty.desc with
+     | Tvariant row ->
+         let row = Btype.row_repr row in
+-        if (Btype.row_more row).desc = Tunivar then
++        if Btype.is_Tunivar (Btype.row_more row) then
+           ty.desc <- Tvariant
+               {row with row_fixed=true;
+                row_fields = List.map
+@@ -512,7 +522,7 @@
+       then try
+         r := (loc, v,  Tbl.find name !type_variables) :: !r
+       with Not_found ->
+-        if fixed && (repr ty).desc = Tvar then
++        if fixed && Btype.is_Tvar (repr ty) then
+           raise(Error(loc, Unbound_type_variable ("'"^name)));
+         let v2 = new_global_var () in
+         r := (loc, v, v2) :: !r;
+@@ -552,8 +562,10 @@
+     List.fold_left
+       (fun acc v ->
+         let v = repr v in
+-        if v.level <> Btype.generic_level || v.desc <> Tvar then acc
+-        else (v.desc <- Tunivar ; v :: acc))
++        match v.desc with
++          Tvar name when v.level = Btype.generic_level ->
++            v.desc <- Tunivar name; v :: acc
++        | _ -> acc)
+       [] !pre_univars
+   in
+   make_fixed_univars typ;
+@@ -635,8 +647,8 @@
+       fprintf ppf "The type variable name %s is not allowed in programs" name
+   | Cannot_quantify (name, v) ->
+       fprintf ppf "This type scheme cannot quantify '%s :@ %s." name
+-        (if v.desc = Tvar then "it escapes this scope" else
+-         if v.desc = Tunivar then "it is aliased to another variable"
++        (if Btype.is_Tvar v then "it escapes this scope" else
++         if Btype.is_Tunivar v then "it is aliased to another variable"
+          else "it is not a variable")
+   | Multiple_constraints_on_type s ->
+       fprintf ppf "Multiple constraints for type %s" s
+Index: typing/btype.ml
+===================================================================
+--- typing/btype.ml    (リビジョン 11207)
++++ typing/btype.ml    (作業コピー)
+@@ -35,9 +35,9 @@
+ let new_id = ref (-1)
+ 
+ let newty2 level desc  =
+-  incr new_id; { desc = desc; level = level; id = !new_id }
++  incr new_id; { desc; level; id = !new_id }
+ let newgenty desc      = newty2 generic_level desc
+-let newgenvar ()       = newgenty Tvar
++let newgenvar ?name () = newgenty (Tvar name)
+ (*
+ let newmarkedvar level =
+   incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
+@@ -46,6 +46,11 @@
+   { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
+ *)
+ 
++(**** Check some types ****)
++
++let is_Tvar = function {desc=Tvar _} -> true | _ -> false
++let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
++
+ (**** Representative of a type ****)
+ 
+ let rec field_kind_repr =
+@@ -139,7 +144,7 @@
+       let rec proxy_obj ty =
+         match ty.desc with
+           Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
+-        | Tvar | Tunivar | Tconstr _ -> ty
++        | Tvar _ | Tunivar _ | Tconstr _ -> ty
+         | Tnil -> ty0
+         | _ -> assert false
+       in proxy_obj ty
+@@ -180,13 +185,13 @@
+     row.row_fields;
+   match (repr row.row_more).desc with
+     Tvariant row -> iter_row f row
+-  | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
++  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ ->
+       Misc.may (fun (_,l) -> List.iter f l) row.row_name
+   | _ -> assert false
+ 
+ let iter_type_expr f ty =
+   match ty.desc with
+-    Tvar                -> ()
++    Tvar _              -> ()
+   | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
+   | Ttuple l            -> List.iter f l
+   | Tconstr (_, l, _)   -> List.iter f l
+@@ -198,7 +203,7 @@
+   | Tnil                -> ()
+   | Tlink ty            -> f ty
+   | Tsubst ty           -> f ty
+-  | Tunivar             -> ()
++  | Tunivar _           -> ()
+   | Tpoly (ty, tyl)     -> f ty; List.iter f tyl
+   | Tpackage (_, _, l)  -> List.iter f l
+ 
+@@ -239,13 +244,13 @@
+    encoding during substitution *)
+ let rec norm_univar ty =
+   match ty.desc with
+-    Tunivar | Tsubst _ -> ty
++    Tunivar _ | Tsubst _ -> ty
+   | Tlink ty           -> norm_univar ty
+   | Ttuple (ty :: _)   -> norm_univar ty
+   | _                  -> assert false
+ 
+ let rec copy_type_desc f = function
+-    Tvar                -> Tvar
++    Tvar _              -> Tvar None (* forget the name *)
+   | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
+   | Ttuple l            -> Ttuple (List.map f l)
+   | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
+@@ -258,7 +263,7 @@
+   | Tnil                -> Tnil
+   | Tlink ty            -> copy_type_desc f ty.desc
+   | Tsubst ty           -> assert false
+-  | Tunivar             -> Tunivar
++  | Tunivar _ as ty     -> ty (* keep the name *)
+   | Tpoly (ty, tyl)     ->
+       let tyl = List.map (fun x -> norm_univar (f x)) tyl in
+       Tpoly (f ty, tyl)
+@@ -447,7 +452,7 @@
+   | Cuniv of type_expr option ref * type_expr option
+ 
+ let undo_change = function
+-    Ctype  (ty, desc)  -> ty.desc <- desc
++    Ctype  (ty, desc) -> ty.desc <- desc
+   | Clevel (ty, level) -> ty.level <- level
+   | Cname  (r, v) -> r := v
+   | Crow   (r, v) -> r := v
+@@ -474,7 +479,22 @@
+ 
+ let log_type ty =
+   if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
+-let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
++let link_type ty ty' =
++  log_type ty;
++  let desc = ty.desc in
++  ty.desc <- Tlink ty';
++  (* Name is a user-supplied name for this unification variable (obtained
++   * through a type annotation for instance). *)
++  match desc, ty'.desc with
++    Tvar name, Tvar name' ->
++      begin match name, name' with
++      | Some _, None ->  log_type ty'; ty'.desc <- Tvar name
++      | None, Some _ ->  ()
++      | Some _, Some _ ->
++          if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
++      | None, None   ->  ()
++      end
++  | _ -> ()
+   (* ; assert (check_memorized_abbrevs ()) *)
+   (*  ; check_expans [] ty' *)
+ let set_level ty level =
+Index: typing/typecore.ml
+===================================================================
+--- typing/typecore.ml (リビジョン 11207)
++++ typing/typecore.ml (作業コピー)
+@@ -633,7 +633,7 @@
+           List.iter generalize vars;
+           let instantiated tv  = 
+             let tv = expand_head !env tv in
+-            tv.desc <> Tvar || tv.level <> generic_level in
++            not (is_Tvar tv) || tv.level <> generic_level in
+           if List.exists instantiated vars then
+             raise (Error(loc, Polymorphic_label (lid_of_label label)))
+         end;
+@@ -1126,7 +1126,7 @@
+     Tarrow (l, _, ty_res, _) ->
+       list_labels_aux env (ty::visited) (l::ls) ty_res
+   | _ ->
+-      List.rev ls, ty.desc = Tvar
++      List.rev ls, is_Tvar ty
+ 
+ let list_labels env ty = list_labels_aux env [] [] ty
+ 
+@@ -1142,9 +1142,10 @@
+       (fun t ->
+         let t = repr t in
+         generalize t;
+-        if t.desc = Tvar && t.level = generic_level then
+-          (log_type t; t.desc <- Tunivar; true)
+-        else false)
++        match t.desc with
++          Tvar name when t.level = generic_level ->
++            log_type t; t.desc <- Tunivar name; true
++        | _ -> false)
+       vars in
+   if List.length vars = List.length vars' then () else
+   let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
+@@ -1158,7 +1159,7 @@
+   match (expand_head env exp.exp_type).desc with
+   | Tarrow _ ->
+       Location.prerr_warning exp.exp_loc Warnings.Partial_application
+-  | Tvar -> ()
++  | Tvar _ -> ()
+   | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+   | _ ->
+       if statement then
+@@ -1742,7 +1743,7 @@
+               let (id, typ) =
+                 filter_self_method env met Private meths privty
+               in
+-              if (repr typ).desc = Tvar then
++              if is_Tvar (repr typ) then
+                 Location.prerr_warning loc
+                   (Warnings.Undeclared_virtual_method met);
+               (Texp_send(obj, Tmeth_val id), typ)
+@@ -1797,7 +1798,7 @@
+                 Location.prerr_warning loc
+                   (Warnings.Not_principal "this use of a polymorphic method");
+               snd (instance_poly false tl ty)
+-          | {desc = Tvar} as ty ->
++          | {desc = Tvar _} as ty ->
+               let ty' = newvar () in
+               unify env (instance ty) (newty(Tpoly(ty',[])));
+               (* if not !Clflags.nolabels then
+@@ -1979,7 +1980,7 @@
+             end_def ();
+             check_univars env false "method" exp ty_expected vars;
+             re { exp with exp_type = instance ty }
+-        | Tvar ->
++        | Tvar _ ->
+             let exp = type_exp env sbody in
+             let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
+             unify_exp env exp ty;
+@@ -2038,7 +2039,7 @@
+               Location.prerr_warning loc
+                 (Warnings.Not_principal "this module packing");
+             (p, nl, tl)
+-        | {desc = Tvar} ->
++        | {desc = Tvar _} ->
+             raise (Error (loc, Cannot_infer_signature))
+         | _ ->
+             raise (Error (loc, Not_a_packed_module ty_expected))
+@@ -2128,7 +2129,7 @@
+               ty_fun
+         | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
+             args, ty_fun, no_labels ty_res'
+-        | Tvar ->  args, ty_fun, false
++        | Tvar _ ->  args, ty_fun, false
+         |  _ -> [], texp.exp_type, false
+       in
+       let args, ty_fun', simple_res = make_args [] texp.exp_type in
+@@ -2192,7 +2193,7 @@
+         let (ty1, ty2) =
+           let ty_fun = expand_head env ty_fun in
+           match ty_fun.desc with
+-            Tvar ->
++            Tvar _ ->
+               let t1 = newvar () and t2 = newvar () in
+               let not_identity = function
+                   Texp_ident(_,{val_kind=Val_prim
+@@ -2335,7 +2336,7 @@
+       begin match (expand_head env exp.exp_type).desc with
+       | Tarrow _ ->
+           Location.prerr_warning exp.exp_loc Warnings.Partial_application
+-      | Tvar ->
++      | Tvar _ ->
+           add_delayed_check (fun () -> check_application_result env false exp)
+       | _ -> ()
+       end;
+@@ -2404,9 +2405,9 @@
+   | Tarrow _ ->
+       Location.prerr_warning loc Warnings.Partial_application
+   | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+-  | Tvar when ty.level > tv.level ->
++  | Tvar _ when ty.level > tv.level ->
+       Location.prerr_warning loc Warnings.Nonreturning_statement
+-  | Tvar ->
++  | Tvar _ ->
+       add_delayed_check (fun () -> check_application_result env true exp)
+   | _ ->
+       Location.prerr_warning loc Warnings.Statement_type
+Index: typing/btype.mli
+===================================================================
+--- typing/btype.mli   (リビジョン 11207)
++++ typing/btype.mli   (作業コピー)
+@@ -23,7 +23,7 @@
+         (* Create a type *)
+ val newgenty: type_desc -> type_expr
+         (* Create a generic type *)
+-val newgenvar: unit -> type_expr
++val newgenvar: ?name:string -> unit -> type_expr
+         (* Return a fresh generic variable *)
+ 
+ (* Use Tsubst instead
+@@ -33,6 +33,9 @@
+         (* Return a fresh marked generic variable *)
+ *)
+ 
++val is_Tvar: type_expr -> bool
++val is_Tunivar: type_expr -> bool
++
+ val repr: type_expr -> type_expr
+         (* Return the canonical representative of a type. *)
+ 
+Index: typing/ctype.mli
+===================================================================
+--- typing/ctype.mli   (リビジョン 11207)
++++ typing/ctype.mli   (作業コピー)
+@@ -41,9 +41,10 @@
+         (* This pair of functions is only used in Typetexp *)
+ 
+ val newty: type_desc -> type_expr
+-val newvar: unit -> type_expr
++val newvar: ?name:string -> unit -> type_expr
++val newvar2: ?name:string -> int -> type_expr
+         (* Return a fresh variable *)
+-val new_global_var: unit -> type_expr
++val new_global_var: ?name:string -> unit -> type_expr
+         (* Return a fresh variable, bound at toplevel
+            (as type variables ['a] in type constraints). *)
+ val newobj: type_expr -> type_expr
+Index: typing/datarepr.ml
+===================================================================
+--- typing/datarepr.ml (リビジョン 11207)
++++ typing/datarepr.ml (作業コピー)
+@@ -28,7 +28,7 @@
+     if ty.level >= lowest_level then begin
+       ty.level <- pivot_level - ty.level;
+       match ty.desc with
+-      | Tvar ->
++      | Tvar _ ->
+           ret := TypeSet.add ty !ret
+       | Tvariant row ->
+           let row = row_repr row in
+Index: typing/typeclass.ml
+===================================================================
+--- typing/typeclass.ml        (リビジョン 11207)
++++ typing/typeclass.ml        (作業コピー)
+@@ -532,7 +532,7 @@
+                 (Typetexp.transl_simple_type val_env false sty) ty
+           end;
+           begin match (Ctype.repr ty).desc with
+-            Tvar ->
++            Tvar _ ->
+               let ty' = Ctype.newvar () in
+               Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
+               Ctype.unify val_env (type_approx val_env sbody) ty'
+Index: typing/typedecl.ml
+===================================================================
+--- typing/typedecl.ml (リビジョン 11207)
++++ typing/typedecl.ml (作業コピー)
+@@ -111,7 +111,7 @@
+     | _ ->
+         raise (Error (loc, Bad_fixed_type "is not an object or variant"))
+   in
+-  if rv.desc <> Tvar then
++  if not (Btype.is_Tvar rv) then
+     raise (Error (loc, Bad_fixed_type "has no row variable"));
+   rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
+ 
+@@ -503,7 +503,7 @@
+           compute_same row.row_more
+       | Tpoly (ty, _) ->
+           compute_same ty
+-      | Tvar | Tnil | Tlink _ | Tunivar -> ()
++      | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
+       | Tpackage (_, _, tyl) ->
+           List.iter (compute_variance_rec true true true) tyl
+     end
+@@ -546,7 +546,7 @@
+   in
+   List.iter2
+     (fun (ty, co, cn, ct) (c, n) ->
+-      if ty.desc <> Tvar then begin
++      if not (Btype.is_Tvar ty) then begin
+         co := c; cn := n; ct := n;
+         compute_variance env tvl2 c n n ty
+       end)
+@@ -571,7 +571,7 @@
+ 
+ let rec anonymous env ty =
+   match (Ctype.expand_head env ty).desc with
+-  | Tvar -> false
++  | Tvar _ -> false
+   | Tobject (fi, _) ->
+       let _, rv = Ctype.flatten_fields fi in anonymous env rv
+   | Tvariant row ->
+Index: typing/types.mli
+===================================================================
+--- typing/types.mli   (リビジョン 11207)
++++ typing/types.mli   (作業コピー)
+@@ -24,7 +24,7 @@
+     mutable id: int }
+ 
+ and type_desc =
+-    Tvar
++    Tvar of string option
+   | Tarrow of label * type_expr * type_expr * commutable
+   | Ttuple of type_expr list
+   | Tconstr of Path.t * type_expr list * abbrev_memo ref
+@@ -34,7 +34,7 @@
+   | Tlink of type_expr
+   | Tsubst of type_expr         (* for copying *)
+   | Tvariant of row_desc
+-  | Tunivar
++  | Tunivar of string option
+   | Tpoly of type_expr * type_expr list
+   | Tpackage of Path.t * string list * type_expr list
+ 
+Index: typing/ctype.ml
+===================================================================
+--- typing/ctype.ml    (リビジョン 11207)
++++ typing/ctype.ml    (作業コピー)
+@@ -153,9 +153,9 @@
+ let newty desc         = newty2 !current_level desc
+ let new_global_ty desc = newty2 !global_level desc
+ 
+-let newvar ()          = newty2 !current_level Tvar
+-let newvar2 level      = newty2 level Tvar
+-let new_global_var ()  = newty2 !global_level Tvar
++let newvar ?name ()         = newty2 !current_level (Tvar name)
++let newvar2 ?name level     = newty2 level (Tvar name)
++let new_global_var ?name () = newty2 !global_level (Tvar name)
+ 
+ let newobj fields      = newty (Tobject (fields, ref None))
+ 
+@@ -297,14 +297,12 @@
+ 
+ let opened_object ty =
+   match (object_row ty).desc with
+-  | Tvar               -> true
+-  | Tunivar            -> true
+-  | Tconstr _          -> true
+-  | _                  -> false
++  | Tvar _  | Tunivar _ | Tconstr _ -> true
++  | _                               -> false
+ 
+ let concrete_object ty =
+   match (object_row ty).desc with
+-  | Tvar               -> false
++  | Tvar _             -> false
+   | _                  -> true
+ 
+ (**** Close an object ****)
+@@ -313,7 +311,7 @@
+   let rec close ty =
+     let ty = repr ty in
+     match ty.desc with
+-      Tvar ->
++      Tvar _ ->
+         link_type ty (newty2 ty.level Tnil)
+     | Tfield(_, _, _, ty') -> close ty'
+     | _                    -> assert false
+@@ -329,7 +327,7 @@
+     let ty = repr ty in
+     match ty.desc with
+       Tfield (_, _, _, ty) -> find ty
+-    | Tvar                 -> ty
++    | Tvar _               -> ty
+     | _                    -> assert false
+   in
+   match (repr ty).desc with
+@@ -434,7 +432,7 @@
+     let level = ty.level in
+     ty.level <- pivot_level - level;
+     match ty.desc with
+-      Tvar when level <> generic_level ->
++      Tvar _ when level <> generic_level ->
+         raise Non_closed
+     | Tfield(_, kind, t1, t2) ->
+         if field_kind_repr kind = Fpresent then
+@@ -468,7 +466,7 @@
+   if ty.level >= lowest_level then begin
+     ty.level <- pivot_level - ty.level;
+     begin match ty.desc, !really_closed with
+-      Tvar, _ ->
++      Tvar _, _ ->
+         free_variables := (ty, real) :: !free_variables
+     | Tconstr (path, tl, _), Some env ->
+         begin try
+@@ -639,7 +637,7 @@
+ let rec generalize_structure var_level ty =
+   let ty = repr ty in
+   if ty.level <> generic_level then begin
+-    if ty.desc = Tvar && ty.level > var_level then
++    if is_Tvar ty && ty.level > var_level then
+       set_level ty var_level
+     else if ty.level > !current_level then begin
+       set_level ty generic_level;
+@@ -858,7 +856,7 @@
+           TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
+           List.iter (add_univar univ) inv.inv_parents
+   in
+-  TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
++  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
+     inverted;
+   fun ty ->
+     try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
+@@ -913,7 +911,7 @@
+             if keep then ty.level else !current_level
+           else generic_level
+     in
+-    if forget <> generic_level then newty2 forget Tvar else
++    if forget <> generic_level then newty2 forget (Tvar None) else
+     let desc = ty.desc in
+     save_desc ty desc;
+     let t = newvar() in          (* Stub *)
+@@ -959,7 +957,7 @@
+                 | Tconstr _ ->
+                     if keep then save_desc more more.desc;
+                     copy more
+-                | Tvar | Tunivar ->
++                | Tvar _ | Tunivar _ ->
+                     save_desc more more.desc;
+                     if keep then more else newty more.desc
+                 |  _ -> assert false
+@@ -1117,7 +1115,7 @@
+     t
+   else try
+     let t, bound_t = List.assq ty visited in
+-    let dl = if ty.desc = Tunivar then [] else diff_list bound bound_t in
++    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
+     if dl <> [] && conflicts univars dl then raise Not_found;
+     t
+   with Not_found -> begin
+@@ -1134,14 +1132,14 @@
+           let row = row_repr row0 in
+           let more = repr row.row_more in
+           (* We shall really check the level on the row variable *)
+-          let keep = more.desc = Tvar && more.level <> generic_level in
++          let keep = is_Tvar more && more.level <> generic_level in
+           let more' = copy_rec more in
+-          let fixed' = fixed && (repr more').desc = Tvar in
++          let fixed' = fixed && is_Tvar (repr more') in
+           let row = copy_row copy_rec fixed' row keep more' in
+           Tvariant row
+       | Tpoly (t1, tl) ->
+           let tl = List.map repr tl in
+-          let tl' = List.map (fun t -> newty Tunivar) tl in
++          let tl' = List.map (fun t -> newty t.desc) tl in
+           let bound = tl @ bound in
+           let visited =
+             List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
+@@ -1395,7 +1393,7 @@
+ let rec full_expand env ty =
+   let ty = repr (expand_head env ty) in
+   match ty.desc with
+-    Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar ->
++    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
+       newty2 ty.level (Tobject (fi, ref None))
+   | _ ->
+       ty
+@@ -1570,8 +1568,8 @@
+         true
+     then
+       match ty.desc with
+-        Tunivar ->
+-          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
++        Tunivar _ ->
++          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()])
+       | Tpoly (ty, tyl) ->
+           let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
+           occur_rec bound  ty
+@@ -1620,7 +1618,7 @@
+         Tpoly (t, tl) ->
+           if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
+           else occur t
+-      | Tunivar ->
++      | Tunivar _ ->
+           if TypeSet.mem t family then raise Occur
+       | Tconstr (_, [], _) -> ()
+       | Tconstr (p, tl, _) ->
+@@ -1784,7 +1782,7 @@
+               t
+           end;
+         iter_type_expr (iterator visited) ty
+-    | Tvar -> 
++    | Tvar _ -> 
+         let t = create_fresh_constr ty.level false in
+         link_type ty t
+     | _ ->
+@@ -1862,8 +1860,8 @@
+   let t2 = repr t2 in
+   if t1 == t2 then () else
+     match (t1.desc, t2.desc) with
+-      | (Tvar, _)  
+-      | (_, Tvar)  ->
++      | (Tvar _, _)  
++      | (_, Tvar _)  ->
+         fatal_error "types should not include variables"
+       | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+         ()
+@@ -1877,7 +1875,7 @@
+           with Not_found ->
+               TypePairs.add type_pairs (t1', t2') ();
+               match (t1'.desc, t2'.desc) with
+-                  (Tvar, Tvar) ->
++                  (Tvar _, Tvar _) ->
+                     fatal_error "types should not include variables"
+                 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+                   || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+@@ -1903,7 +1901,7 @@
+                 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+                   enter_poly env univar_pairs t1 tl1 t2 tl2
+                     (mcomp type_pairs subst env)
+-                | (Tunivar, Tunivar) ->
++                | (Tunivar _, Tunivar _) ->
+                   unify_univar t1' t2' !univar_pairs
+                 | (_, _) ->
+                   raise (Unify [])
+@@ -2048,21 +2046,21 @@
+   try
+     type_changed := true;
+     match (t1.desc, t2.desc) with
+-      (Tvar, Tconstr _) when deep_occur t1 t2 ->
++      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
+         unify2 env t1 t2
+-    | (Tconstr _, Tvar) when deep_occur t2 t1 ->
++    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
+         unify2 env t1 t2
+-    | (Tvar, _) ->
++    | (Tvar _, _) ->
+         occur !env t1 t2; 
+         occur_univar !env t2;
+         link_type t1 t2;
+         update_level !env t1.level t2
+-    | (_, Tvar) ->
++    | (_, Tvar _) ->
+         occur !env t2 t1; 
+         occur_univar !env t1;
+         link_type t2 t1;
+         update_level !env t2.level t1
+-    | (Tunivar, Tunivar) ->
++    | (Tunivar _, Tunivar _) ->
+         unify_univar t1 t2 !univar_pairs;
+         update_level !env t1.level t2;
+         link_type t1 t2
+@@ -2104,7 +2102,7 @@
+   (* Assumes either [t1 == t1'] or [t2 != t2'] *)
+   let d1 = t1'.desc and d2 = t2'.desc in
+   match (d1, d2) with (* handle univars specially *)
+-    (Tunivar, Tunivar) ->
++    (Tunivar _, Tunivar _) ->
+       unify_univar t1' t2' !univar_pairs;
+       update_level !env t1'.level t2';
+       link_type t1' t2'
+@@ -2127,12 +2125,12 @@
+     | Old -> f () (* old_link was already called *)
+   in
+   match d1, d2 with
+-  | Tvar,_ ->
++  | Tvar _, _ ->
+       occur !env t1 t2';
+       occur_univar !env t2;
+       update_level !env t1'.level t2;
+       link_type t1' t2;      
+-  | _, Tvar ->
++  | _, Tvar _ ->
+       occur !env t2 t1';
+       occur_univar !env t1;
+       update_level !env t2'.level t1;
+@@ -2149,8 +2147,8 @@
+           add_type_equality t1' t2' end;
+       try
+         begin match (d1, d2) with
+-        | (Tvar, _) 
+-        | (_, Tvar) ->
++        | (Tvar _, _) 
++        | (_, Tvar _) ->
+             (* cases taken care of *)
+             assert false
+         | (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
+@@ -2214,8 +2212,9 @@
+             (* Type [t2'] may have been instantiated by [unify_fields] *)
+             (* XXX One should do some kind of unification... *)
+             begin match (repr t2').desc with
+-              Tobject (_, {contents = Some (_, va::_)})
+-              when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
++              Tobject (_, {contents = Some (_, va::_)}) when
++            (match (repr va).desc with
++              Tvar _|Tunivar _|Tnil -> true | _ -> false) ->
+                 ()
+             | Tobject (_, nm2) ->
+                 set_name nm2 !nm1
+@@ -2290,16 +2289,32 @@
+     raise (Unify []);
+   List.iter2 (unify env) tl1 tl2
+ 
++(* Build a fresh row variable for unification *)
++and make_rowvar level use1 rest1 use2 rest2  =
++  let set_name ty name =
++    match ty.desc with
++      Tvar None -> log_type ty; ty.desc <- Tvar name
++    | _ -> ()
++  in
++  let name =
++    match rest1.desc, rest2.desc with
++      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
++        if rest1.level <= rest2.level then name1 else name2
++    | Tvar (Some _ as name), _ ->
++        if use2 then set_name rest2 name; name
++    | _, Tvar (Some _ as name) ->
++        if use1 then set_name rest2 name; name
++    | _ -> None
++  in
++  if use1 then rest1 else
++  if use2 then rest2 else newvar2 ?name level
++
+ and unify_fields env ty1 ty2 =          (* Optimization *)
+   let (fields1, rest1) = flatten_fields ty1
+   and (fields2, rest2) = flatten_fields ty2 in
+   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+   let l1 = (repr ty1).level and l2 = (repr ty2).level in
+-  let va =
+-    if miss1 = [] then rest2
+-    else if miss2 = [] then rest1
+-    else newty2 (min l1 l2) Tvar
+-  in
++  let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
+   let d1 = rest1.desc and d2 = rest2.desc in
+   try
+     unify env (build_fields l1 miss1 va) rest2;
+@@ -2390,7 +2405,7 @@
+     let rm = row_more row in
+     if row.row_fixed then
+       if row0.row_more == rm then () else
+-      if rm.desc = Tvar then link_type rm row0.row_more else
++      if is_Tvar rm then link_type rm row0.row_more else
+       unify env rm row0.row_more
+     else
+       let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in
+@@ -2489,7 +2504,7 @@
+   let t1 = repr t1 and t2 = repr t2 in
+   if t1 == t2 then () else
+   match t1.desc with
+-    Tvar ->
++    Tvar _ ->
+       begin try
+         occur env t1 t2;
+         update_level env t1.level t2;
+@@ -2527,7 +2542,7 @@
+ let rec filter_arrow env t l =
+   let t = expand_head_unif env t in
+   match t.desc with
+-    Tvar ->
++    Tvar _ ->
+       let lv = t.level in
+       let t1 = newvar2 lv and t2 = newvar2 lv in
+       let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
+@@ -2543,7 +2558,7 @@
+ let rec filter_method_field env name priv ty =
+   let ty = repr ty in
+   match ty.desc with
+-    Tvar ->
++    Tvar _ ->
+       let level = ty.level in
+       let ty1 = newvar2 level and ty2 = newvar2 level in
+       let ty' = newty2 level (Tfield (name,
+@@ -2570,7 +2585,7 @@
+ let rec filter_method env name priv ty =
+   let ty = expand_head_unif env ty in
+   match ty.desc with
+-    Tvar ->
++    Tvar _ ->
+       let ty1 = newvar () in
+       let ty' = newobj ty1 in
+       update_level env ty.level ty';
+@@ -2606,7 +2621,7 @@
+   let rec occur ty =
+     let ty = repr ty in
+     if ty.level > level then begin
+-      if ty.desc = Tvar && ty.level >= generic_level - 1 then raise Occur;
++      if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
+       ty.level <- pivot_level - ty.level;
+       match ty.desc with
+         Tvariant row when static_row row ->
+@@ -2636,7 +2651,7 @@
+ 
+   try
+     match (t1.desc, t2.desc) with
+-      (Tvar, _) when may_instantiate inst_nongen t1 ->
++      (Tvar _, _) when may_instantiate inst_nongen t1 ->
+         moregen_occur env t1.level t2;
+         occur env t1 t2;
+         link_type t1 t2
+@@ -2653,7 +2668,7 @@
+         with Not_found ->
+           TypePairs.add type_pairs (t1', t2') ();
+           match (t1'.desc, t2'.desc) with
+-            (Tvar, _) when may_instantiate inst_nongen t1' ->
++            (Tvar _, _) when may_instantiate inst_nongen t1' ->
+               moregen_occur env t1'.level t2;
+               link_type t1' t2
+           | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
+@@ -2684,7 +2699,7 @@
+           | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+               enter_poly env univar_pairs t1 tl1 t2 tl2
+                 (moregen inst_nongen type_pairs env)
+-          | (Tunivar, Tunivar) ->
++          | (Tunivar _, Tunivar _) ->
+               unify_univar t1' t2' !univar_pairs
+           | (_, _) ->
+               raise (Unify [])
+@@ -2725,7 +2740,7 @@
+   let row1 = row_repr row1 and row2 = row_repr row2 in
+   let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
+   if rm1 == rm2 then () else
+-  let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in
++  let may_inst = is_Tvar rm1 && may_instantiate inst_nongen rm1 in
+   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+   let r1, r2 =
+     if row2.row_closed then
+@@ -2735,9 +2750,9 @@
+   if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
+   then raise (Unify []);
+   begin match rm1.desc, rm2.desc with
+-    Tunivar, Tunivar ->
++    Tunivar _, Tunivar _ ->
+       unify_univar rm1 rm2 !univar_pairs
+-  | Tunivar, _ | _, Tunivar ->
++  | Tunivar _, _ | _, Tunivar _ ->
+       raise (Unify [])
+   | _ when static_row row1 -> ()
+   | _ when may_inst ->
+@@ -2828,13 +2843,13 @@
+   if ty.level >= lowest_level then begin
+     ty.level <- pivot_level - ty.level;
+     match ty.desc with
+-    | Tvar ->
++    | Tvar _ ->
+         if not (List.memq ty !vars) then vars := ty :: !vars
+     | Tvariant row ->
+         let row = row_repr row in
+         let more = repr row.row_more in
+-        if more.desc = Tvar && not row.row_fixed then begin
+-          let more' = newty2 more.level Tvar in
++        if is_Tvar more && not row.row_fixed then begin
++          let more' = newty2 more.level more.desc in
+           let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
+           in link_type more (newty2 ty.level (Tvariant row'))
+         end;
+@@ -2857,7 +2872,7 @@
+     (fun ty ->
+       let ty = expand_head env ty in
+       if List.memq ty !tyl then false else
+-      (tyl := ty :: !tyl; ty.desc = Tvar))
++      (tyl := ty :: !tyl; is_Tvar ty))
+     vars
+ 
+ let matches env ty ty' =
+@@ -2901,7 +2916,7 @@
+ 
+   try
+     match (t1.desc, t2.desc) with
+-      (Tvar, Tvar) when rename ->
++      (Tvar _, Tvar _) when rename ->
+         begin try
+           normalize_subst subst;
+           if List.assq t1 !subst != t2 then raise (Unify [])
+@@ -2922,7 +2937,7 @@
+         with Not_found ->
+           TypePairs.add type_pairs (t1', t2') ();
+           match (t1'.desc, t2'.desc) with
+-            (Tvar, Tvar) when rename ->
++            (Tvar _, Tvar _) when rename ->
+               begin try
+                 normalize_subst subst;
+                 if List.assq t1' !subst != t2' then raise (Unify [])
+@@ -2956,7 +2971,7 @@
+           | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+               enter_poly env univar_pairs t1 tl1 t2 tl2
+                 (eqtype rename type_pairs subst env)
+-          | (Tunivar, Tunivar) ->
++          | (Tunivar _, Tunivar _) ->
+               unify_univar t1' t2' !univar_pairs
+           | (_, _) ->
+               raise (Unify [])
+@@ -3405,7 +3420,7 @@
+ let rec build_subtype env visited loops posi level t =
+   let t = repr t in
+   match t.desc with
+-    Tvar ->
++    Tvar _ ->
+       if posi then
+         try
+           let t' = List.assq t loops in
+@@ -3454,13 +3469,13 @@
+              as this occurence might break the occur check.
+              XXX not clear whether this correct anyway... *)
+           if List.exists (deep_occur ty) tl1 then raise Not_found;
+-          ty.desc <- Tvar;
++          ty.desc <- Tvar None;
+           let t'' = newvar () in
+           let loops = (ty, t'') :: loops in
+           (* May discard [visited] as level is going down *)
+           let (ty1', c) =
+             build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
+-          assert (t''.desc = Tvar);
++          assert (is_Tvar t'');
+           let nm =
+             if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
+           t''.desc <- Tobject (ty1', ref nm);
+@@ -3559,7 +3574,7 @@
+       let (t1', c) = build_subtype env visited loops posi level t1 in
+       if c > Unchanged then (newty (Tpoly(t1', tl)), c)
+       else (t, Unchanged)
+-  | Tunivar | Tpackage _ ->
++  | Tunivar _ | Tpackage _ ->
+       (t, Unchanged)
+ 
+ let enlarge_type env ty =
+@@ -3623,7 +3638,7 @@
+   with Not_found ->
+     TypePairs.add subtypes (t1, t2) ();
+     match (t1.desc, t2.desc) with
+-      (Tvar, _) | (_, Tvar) ->
++      (Tvar _, _) | (_, Tvar _) ->
+         (trace, t1, t2, !univar_pairs)::cstrs
+     | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
+       || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+@@ -3659,7 +3674,7 @@
+     | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 ->
+         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
+     | (Tobject (f1, _), Tobject (f2, _))
+-      when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar ->
++      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
+         (* Same row variable implies same object. *)
+         (trace, t1, t2, !univar_pairs)::cstrs
+     | (Tobject (f1, _), Tobject (f2, _)) ->
+@@ -3731,7 +3746,7 @@
+   match more1.desc, more2.desc with
+     Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
+       subtype_rec env ((more1,more2)::trace) more1 more2 cstrs
+-  | (Tvar|Tconstr _), (Tvar|Tconstr _)
++  | (Tvar _|Tconstr _), (Tvar _|Tconstr _)
+     when row1.row_closed && r1 = [] ->
+       List.fold_left
+         (fun cstrs (_,f1,f2) ->
+@@ -3745,7 +3760,7 @@
+           | Rabsent, _ -> cstrs
+           | _ -> raise Exit)
+         cstrs pairs
+-  | Tunivar, Tunivar
++  | Tunivar _, Tunivar _
+     when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
+       let cstrs =
+         subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in
+@@ -3789,19 +3804,19 @@
+   match ty.desc with
+     Tfield (s, k, t1, t2) ->
+       newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
+-  | Tvar | Tnil ->
++  | Tvar _ | Tnil ->
+       newty2 ty.level ty.desc
+-  | Tunivar ->
++  | Tunivar _ ->
+       ty
+   | Tconstr _ ->
+-      newty2 ty.level Tvar
++      newvar2 ty.level
+   | _ ->
+       assert false
+ 
+ let unalias ty =
+   let ty = repr ty in
+   match ty.desc with
+-    Tvar | Tunivar ->
++    Tvar _ | Tunivar _ ->
+       ty
+   | Tvariant row ->
+       let row = row_repr row in
+@@ -3875,7 +3890,7 @@
+               set_name nm None
+             else let v' = repr v in
+             begin match v'.desc with
+-            | Tvar|Tunivar ->
++            | Tvar _ | Tunivar _ ->
+                 if v' != v then set_name nm (Some (n, v' :: l))
+             | Tnil ->
+                 log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
+@@ -3917,7 +3932,7 @@
+ 
+ let rec nondep_type_rec env id ty =
+   match ty.desc with
+-    Tvar | Tunivar -> ty
++    Tvar _ | Tunivar _ -> ty
+   | Tlink ty -> nondep_type_rec env id ty
+   | _ -> try TypeHash.find nondep_hash ty
+   with Not_found ->
+@@ -3987,7 +4002,7 @@
+ 
+ let unroll_abbrev id tl ty =
+   let ty = repr ty and path = Path.Pident id in
+-  if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl)
++  if is_Tvar ty || (List.exists (deep_occur ty) tl)
+   || is_object_type path then
+     ty
+   else
+Index: typing/printtyp.ml
+===================================================================
+--- typing/printtyp.ml (リビジョン 11207)
++++ typing/printtyp.ml (作業コピー)
+@@ -109,6 +109,10 @@
+   | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem
+   | Mlink rem -> list_of_memo !rem
+ 
++let print_name ppf = function
++    None -> fprintf ppf "None"
++  | Some name -> fprintf ppf "\"%s\"" name
++
+ let visited = ref []
+ let rec raw_type ppf ty =
+   let ty = safe_repr [] ty in
+@@ -119,7 +123,7 @@
+   end
+ and raw_type_list tl = raw_list raw_type tl
+ and raw_type_desc ppf = function
+-    Tvar -> fprintf ppf "Tvar"
++    Tvar name -> fprintf ppf "Tvar %a" print_name name
+   | Tarrow(l,t1,t2,c) ->
+       fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
+         l raw_type t1 raw_type t2
+@@ -143,7 +147,7 @@
+   | Tnil -> fprintf ppf "Tnil"
+   | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
+   | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
+-  | Tunivar -> fprintf ppf "Tunivar"
++  | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
+   | Tpoly (t, tl) ->
+       fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
+         raw_type t
+@@ -189,28 +193,61 @@
+ 
+ let names = ref ([] : (type_expr * string) list)
+ let name_counter = ref 0
++let named_vars = ref ([] : string list)
+ 
+-let reset_names () = names := []; name_counter := 0
++let reset_names () = names := []; name_counter := 0; named_vars := []
++let add_named_var ty =
++  match ty.desc with
++    Tvar (Some name) | Tunivar (Some name) ->
++      if List.mem name !named_vars then () else
++      named_vars := name :: !named_vars
++  | _ -> ()
+ 
+-let new_name () =
++let rec new_name () =
+   let name =
+     if !name_counter < 26
+     then String.make 1 (Char.chr(97 + !name_counter))
+     else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
+            string_of_int(!name_counter / 26) in
+   incr name_counter;
+-  name
++  if List.mem name !named_vars
++  || List.exists (fun (_, name') -> name = name') !names
++  then new_name ()
++  else name
+ 
+ let name_of_type t =
++  (* We've already been through repr at this stage, so t is our representative
++     of the union-find class. *)
+   try List.assq t !names with Not_found ->
+-    let name = new_name () in
++    let name =
++      match t.desc with
++        Tvar (Some name) | Tunivar (Some name) ->
++          (* Some part of the type we've already printed has assigned another
++           * unification variable to that name. We want to keep the name, so try
++           * adding a number until we find a name that's not taken. *)
++          let current_name = ref name in
++          let i = ref 0 in
++          while List.exists (fun (_, name') -> !current_name = name') !names do
++            current_name := name ^ (string_of_int !i);
++            i := !i + 1;
++          done;
++          !current_name
++      | _ ->
++          (* No name available, create a new one *)
++          new_name ()
++    in
+     names := (t, name) :: !names;
+     name
+ 
+ let check_name_of_type t = ignore(name_of_type t)
+ 
++let remove_names tyl =
++  let tyl = List.map repr tyl in
++  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
++
++
+ let non_gen_mark sch ty =
+-  if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
++  if sch && is_Tvar ty && ty.level <> generic_level then "_" else ""
+ 
+ let print_name_of_type sch ppf t =
+   fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t)
+@@ -225,9 +262,13 @@
+ let is_aliased ty = List.memq (proxy ty) !aliased
+ let add_alias ty =
+   let px = proxy ty in
+-  if not (is_aliased px) then aliased := px :: !aliased
++  if not (is_aliased px) then begin
++    aliased := px :: !aliased;
++    add_named_var px
++  end
++
+ let aliasable ty =
+-  match ty.desc with Tvar | Tunivar | Tpoly _ -> false | _ -> true
++  match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true
+ 
+ let namable_row row =
+   row.row_name <> None &&
+@@ -245,7 +286,7 @@
+   if List.memq px visited && aliasable ty then add_alias px else
+     let visited = px :: visited in
+     match ty.desc with
+-    | Tvar -> ()
++    | Tvar _ -> add_named_var ty
+     | Tarrow(_, ty1, ty2, _) ->
+         mark_loops_rec visited ty1; mark_loops_rec visited ty2
+     | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
+@@ -290,7 +331,7 @@
+     | Tpoly (ty, tyl) ->
+         List.iter (fun t -> add_alias t) tyl;
+         mark_loops_rec visited ty
+-    | Tunivar -> ()
++    | Tunivar _ -> add_named_var ty
+ 
+ let mark_loops ty =
+   normalize_type Env.empty ty;
+@@ -322,7 +363,7 @@
+ 
+   let pr_typ () =
+     match ty.desc with
+-    | Tvar ->
++    | Tvar _ ->
+         Otyp_var (is_non_gen sch ty, name_of_type ty)
+     | Tarrow(l, ty1, ty2, _) ->
+         let pr_arrow l ty1 ty2 =
+@@ -387,16 +428,22 @@
+     | Tpoly (ty, []) ->
+         tree_of_typexp sch ty
+     | Tpoly (ty, tyl) ->
++        (*let print_names () =
++          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
++          prerr_string "; " in *)
+         let tyl = List.map repr tyl in
+-        (* let tyl = List.filter is_aliased tyl in *)
+         if tyl = [] then tree_of_typexp sch ty else begin
+           let old_delayed = !delayed in
++          (* Make the names delayed, so that the real type is
++             printed once when used as proxy *)
+           List.iter add_delayed tyl;
+           let tl = List.map name_of_type tyl in
+           let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
++          (* Forget names when we leave scope *)
++          remove_names tyl;
+           delayed := old_delayed; tr
+         end
+-    | Tunivar ->
++    | Tunivar _ ->
+         Otyp_var (false, name_of_type ty)
+     | Tpackage (p, n, tyl) ->
+         Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
+@@ -446,13 +493,13 @@
+   end
+ 
+ and is_non_gen sch ty =
+-    sch && ty.desc = Tvar && ty.level <> generic_level
++    sch && is_Tvar ty && ty.level <> generic_level
+ 
+ and tree_of_typfields sch rest = function
+   | [] ->
+       let rest =
+         match rest.desc with
+-        | Tvar | Tunivar -> Some (is_non_gen sch rest)
++        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
+         | Tconstr _ -> Some false
+         | Tnil -> None
+         | _ -> fatal_error "typfields (1)"
+@@ -564,7 +611,7 @@
+     let vari =
+       List.map2
+         (fun ty (co,cn,ct) ->
+-          if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true))
++          if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true))
+         decl.type_params decl.type_variance
+     in
+     (Ident.name id,
+@@ -645,16 +692,18 @@
+ 
+ let method_type (_, kind, ty) =
+   match field_kind_repr kind, repr ty with
+-    Fpresent, {desc=Tpoly(ty, _)} -> ty
+-  | _       , ty                  -> ty
++    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
++  | _       , ty                    -> (ty, [])
+ 
+ let tree_of_metho sch concrete csil (lab, kind, ty) =
+   if lab <> dummy_method then begin
+     let kind = field_kind_repr kind in
+     let priv = kind <> Fpresent in
+     let virt = not (Concr.mem lab concrete) in
+-    let ty = method_type (lab, kind, ty) in
+-    Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil
++    let (ty, tyl) = method_type (lab, kind, ty) in
++    let tty = tree_of_typexp sch ty in
++    remove_names tyl;
++    Ocsg_method (lab, priv, virt, tty) :: csil
+   end
+   else csil
+ 
+@@ -662,7 +711,7 @@
+   | Tcty_constr (p, tyl, cty) ->
+       let sty = Ctype.self_type cty in
+       if List.memq (proxy sty) !visited_objects
+-      || List.exists (fun ty -> (repr ty).desc <> Tvar) params
++      || not (List.for_all is_Tvar params)
+       || List.exists (deep_occur sty) tyl
+       then prepare_class_type params cty
+       else List.iter mark_loops tyl
+@@ -675,7 +724,7 @@
+       let (fields, _) =
+         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
+       in
+-      List.iter (fun met -> mark_loops (method_type met)) fields;
++      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
+       Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
+   | Tcty_fun (_, ty, cty) ->
+       mark_loops ty;
+@@ -686,7 +735,7 @@
+   | Tcty_constr (p', tyl, cty) ->
+       let sty = Ctype.self_type cty in
+       if List.memq (proxy sty) !visited_objects
+-      || List.exists (fun ty -> (repr ty).desc <> Tvar) params
++      || not (List.for_all is_Tvar params)
+       then
+         tree_of_class_type sch params cty
+       else
+@@ -743,7 +792,7 @@
+   (match tree_of_typexp true param with
+     Otyp_var (_, s) -> s
+   | _ -> "?"),
+-  if (repr param).desc = Tvar then (true, true) else variance
++  if is_Tvar (repr param) then (true, true) else variance
+ 
+ let tree_of_class_params params =
+   let tyl = tree_of_typlist true params in
+@@ -890,7 +939,7 @@
+   | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
+       newty2 t.level
+         (Tvariant {(row_repr row) with row_name = None;
+-                   row_more = newty2 (row_more row).level Tvar})
++                   row_more = newvar2 (row_more row).level})
+   | _ -> t
+ 
+ let prepare_expansion (t, t') =
+@@ -913,9 +962,9 @@
+ let has_explanation unif t3 t4 =
+   match t3.desc, t4.desc with
+     Tfield _, _ | _, Tfield _
+-  | Tunivar, Tvar | Tvar, Tunivar
++  | Tunivar _, Tvar _ | Tvar _, Tunivar _
+   | Tvariant _, Tvariant _ -> true
+-  | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) ->
++  | Tconstr (p, _, _), Tvar _ | Tvar _, Tconstr (p, _, _) ->
+       unif && min t3.level t4.level < Path.binding_time p
+   | _ -> false
+ 
+@@ -931,21 +980,21 @@
+ 
+ let explanation unif t3 t4 ppf =
+   match t3.desc, t4.desc with
+-  | Tfield _, Tvar | Tvar, Tfield _ ->
++  | Tfield _, Tvar _ | Tvar _, Tfield _ ->
+       fprintf ppf "@,Self type cannot escape its class"
+-  | Tconstr (p, tl, _), Tvar
++  | Tconstr (p, tl, _), Tvar _
+     when unif && (tl = [] || t4.level < Path.binding_time p) ->
+       fprintf ppf
+         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+         path p
+-  | Tvar, Tconstr (p, tl, _)
++  | Tvar _, Tconstr (p, tl, _)
+     when unif && (tl = [] || t3.level < Path.binding_time p) ->
+       fprintf ppf
+         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+         path p
+-  | Tvar, Tunivar | Tunivar, Tvar ->
++  | Tvar _, Tunivar _ | Tunivar _, Tvar _ ->
+       fprintf ppf "@,The universal variable %a would escape its scope"
+-        type_expr (if t3.desc = Tunivar then t3 else t4)
++        type_expr (if is_Tunivar t3 then t3 else t4)
+   | Tfield (lab, _, _, _), _
+   | _, Tfield (lab, _, _, _) when lab = dummy_method ->
+       fprintf ppf
+Index: typing/includecore.ml
+===================================================================
+--- typing/includecore.ml      (リビジョン 11207)
++++ typing/includecore.ml      (作業コピー)
+@@ -61,7 +61,7 @@
+     Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
+       let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
+       Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
+-      (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) &&
++      (match row1.row_more with {desc=Tvar _|Tconstr _} -> true | _ -> false) &&
+       let r1, r2, pairs =
+         Ctype.merge_row_fields row1.row_fields row2.row_fields in
+       (not row2.row_closed ||
+@@ -91,7 +91,7 @@
+       let (fields2,rest2) = Ctype.flatten_fields fi2 in
+       Ctype.equal env true (ty1::params1) (rest2::params2) &&
+       let (fields1,rest1) = Ctype.flatten_fields fi1 in
+-      (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) &&
++      (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
+       let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+       miss2 = [] &&
+       let tl1, tl2 =
+@@ -251,7 +251,7 @@
+ let encode_val (mut, ty) rem =
+   begin match mut with
+     Asttypes.Mutable   -> Predef.type_unit
+-  | Asttypes.Immutable -> Btype.newgenty Tvar
++  | Asttypes.Immutable -> Btype.newgenvar ()
+   end
+   ::ty::rem
+ 
+Index: typing/subst.ml
+===================================================================
+--- typing/subst.ml    (リビジョン 11207)
++++ typing/subst.ml    (作業コピー)
+@@ -71,16 +71,19 @@
+ let reset_for_saving () = new_id := -1
+ 
+ let newpersty desc =
+-  decr new_id; { desc = desc; level = generic_level; id = !new_id }
++  decr new_id;
++  { desc = desc; level = generic_level; id = !new_id }
+ 
+ (* Similar to [Ctype.nondep_type_rec]. *)
+ let rec typexp s ty =
+   let ty = repr ty in
+   match ty.desc with
+-    Tvar | Tunivar ->
++    Tvar _ | Tunivar _ ->
+       if s.for_saving || ty.id < 0 then
++        let desc = match ty.desc with (* Tvar _ -> Tvar None *) | d -> d in
+         let ty' =
+-          if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc
++          if s.for_saving then newpersty desc
++          else newty2 ty.level desc
+         in
+         save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty'
+       else ty
+@@ -94,7 +97,7 @@
+     let desc = ty.desc in
+     save_desc ty desc;
+     (* Make a stub *)
+-    let ty' = if s.for_saving then newpersty Tvar else newgenvar () in
++    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
+     ty.desc <- Tsubst ty';
+     ty'.desc <-
+       begin match desc with
+@@ -127,10 +130,10 @@
+                 match more.desc with
+                   Tsubst ty -> ty
+                 | Tconstr _ -> typexp s more
+-                | Tunivar | Tvar ->
++                | Tunivar _ | Tvar _ ->
+                     save_desc more more.desc;
+                     if s.for_saving then newpersty more.desc else
+-                    if dup && more.desc <> Tunivar then newgenvar () else more
++                    if dup && is_Tvar more then newgenty more.desc else more
+                 | _ -> assert false
+               in
+               (* Register new type first for recursion *)
+Index: typing/types.ml
+===================================================================
+--- typing/types.ml    (リビジョン 11207)
++++ typing/types.ml    (作業コピー)
+@@ -25,7 +25,7 @@
+     mutable id: int }
+ 
+ and type_desc =
+-    Tvar
++    Tvar of string option
+   | Tarrow of label * type_expr * type_expr * commutable
+   | Ttuple of type_expr list
+   | Tconstr of Path.t * type_expr list * abbrev_memo ref
+@@ -35,7 +35,7 @@
+   | Tlink of type_expr
+   | Tsubst of type_expr         (* for copying *)
+   | Tvariant of row_desc
+-  | Tunivar
++  | Tunivar of string option
+   | Tpoly of type_expr * type_expr list
+   | Tpackage of Path.t * string list * type_expr list
+ 
+Index: ocamldoc/odoc_str.ml
+===================================================================
+--- ocamldoc/odoc_str.ml       (リビジョン 11207)
++++ ocamldoc/odoc_str.ml       (作業コピー)
+@@ -31,7 +31,7 @@
+   | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2
+   | Types.Ttuple _
+   | Types.Tconstr _
+-  | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
++  | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
+   | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
+ 
+ let raw_string_of_type_list sep type_list =
+@@ -43,7 +43,7 @@
+     | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2
+     | Types.Tconstr _ ->
+         false
+-    | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
++    | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
+     | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
+   in
+   let print_one_type variance t =
+Index: ocamldoc/odoc_value.ml
+===================================================================
+--- ocamldoc/odoc_value.ml     (リビジョン 11207)
++++ ocamldoc/odoc_value.ml     (作業コピー)
+@@ -77,13 +77,13 @@
+     | Types.Tsubst texp ->
+         iter texp
+     | Types.Tpoly (texp, _) -> iter texp
+-    | Types.Tvar
++    | Types.Tvar _
+     | Types.Ttuple _
+     | Types.Tconstr _
+     | Types.Tobject _
+     | Types.Tfield _
+     | Types.Tnil
+-    | Types.Tunivar
++    | Types.Tunivar _
+     | Types.Tpackage _
+     | Types.Tvariant _ ->
+         []
+Index: ocamldoc/odoc_misc.ml
+===================================================================
+--- ocamldoc/odoc_misc.ml      (リビジョン 11207)
++++ ocamldoc/odoc_misc.ml      (作業コピー)
+@@ -478,8 +478,8 @@
+     match t with
+     | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc
+     | Types.Tconstr _
+-    | Types.Tvar
+-    | Types.Tunivar
++    | Types.Tvar _
++    | Types.Tunivar _
+     | Types.Tpoly _
+     | Types.Tarrow _
+     | Types.Ttuple _
+Index: bytecomp/typeopt.ml
+===================================================================
+--- bytecomp/typeopt.ml        (リビジョン 11207)
++++ bytecomp/typeopt.ml        (作業コピー)
+@@ -50,7 +50,7 @@
+ 
+ let array_element_kind env ty =
+   match scrape env ty with
+-  | Tvar | Tunivar ->
++  | Tvar _ | Tunivar _ ->
+       Pgenarray
+   | Tconstr(p, args, abbrev) ->
+       if Path.same p Predef.path_int || Path.same p Predef.path_char then
+Index: bytecomp/translcore.ml
+===================================================================
+--- bytecomp/translcore.ml     (リビジョン 11207)
++++ bytecomp/translcore.ml     (作業コピー)
+@@ -780,12 +780,13 @@
+           begin match e.exp_type.desc with
+           (* the following may represent a float/forward/lazy: need a
+              forward_tag *)
+-          | Tvar | Tlink _ | Tsubst _ | Tunivar
++          | Tvar _ | Tlink _ | Tsubst _ | Tunivar _
+           | Tpoly(_,_) | Tfield(_,_,_,_) ->
+               Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
+           (* the following cannot be represented as float/forward/lazy:
+              optimize *)
+-          | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _
++          | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil
++          | Tvariant _
+               -> transl_exp e
+           (* optimize predefined types (excepted float) *)
+           | Tconstr(_,_,_) ->
+Index: testsuite/tests/lib-hashtbl/htbl.ml
+===================================================================
+--- testsuite/tests/lib-hashtbl/htbl.ml        (リビジョン 11207)
++++ testsuite/tests/lib-hashtbl/htbl.ml        (作業コピー)
+@@ -76,7 +76,7 @@
+   struct
+     type key = M.key
+     type 'a t = (key, 'a) Hashtbl.t
+-    let create = Hashtbl.create
++    let create s = Hashtbl.create s
+     let clear = Hashtbl.clear
+     let copy = Hashtbl.copy
+     let add = Hashtbl.add
+Index: toplevel/genprintval.ml
+===================================================================
+--- toplevel/genprintval.ml    (リビジョン 11207)
++++ toplevel/genprintval.ml    (作業コピー)
+@@ -180,7 +180,7 @@
+           find_printer env ty obj
+         with Not_found ->
+           match (Ctype.repr ty).desc with
+-          | Tvar ->
++          | Tvar _ | Tunivar _ ->
+               Oval_stuff "<poly>"
+           | Tarrow(_, ty1, ty2, _) ->
+               Oval_stuff "<fun>"
+@@ -327,8 +327,6 @@
+               fatal_error "Printval.outval_of_value"
+           | Tpoly (ty, _) ->
+               tree_of_val (depth - 1) obj ty
+-          | Tunivar ->
+-              Oval_stuff "<poly>"
+           | Tpackage _ ->
+               Oval_stuff "<module>"
+         end
+Index: otherlibs/labltk/browser/searchid.ml
+===================================================================
+--- otherlibs/labltk/browser/searchid.ml       (リビジョン 11207)
++++ otherlibs/labltk/browser/searchid.ml       (作業コピー)
+@@ -101,7 +101,7 @@
+ 
+ let rec equal ~prefix t1 t2 =
+   match (repr t1).desc, (repr t2).desc with
+-    Tvar, Tvar -> true
++    Tvar _, Tvar _ -> true
+   | Tvariant row1, Tvariant row2 ->
+       let row1 = row_repr row1 and row2 = row_repr row2 in
+       let fields1 = filter_row_fields false row1.row_fields
+@@ -144,7 +144,7 @@
+ 
+ let rec included ~prefix t1 t2 =
+   match (repr t1).desc, (repr t2).desc with
+-    Tvar, _ -> true
++    Tvar _, _ -> true
+   | Tvariant row1, Tvariant row2 ->
+       let row1 = row_repr row1 and row2 = row_repr row2 in
+       let fields1 = filter_row_fields false row1.row_fields

diff --git a/experimental/garrigue/variable-names.ml b/experimental/garrigue/variable-names.ml
new file mode 100644 (file)
index 0000000..f3c7771
--- /dev/null
+++ b/experimental/garrigue/variable-names.ml
@@ -0,0 +1,4 @@
+let f (x : < a:int; .. > as 'me1) = (x : < b:bool; .. > as 'me2);;
+let f (x : < a:int; .. > as 'me1) = (x : < a:int; b:bool; .. > as 'me2);;
+let f (x : [> `A of int] as 'me1) = (x : [> `B of bool] as 'me2);;
+let f (x : [> `A of int] as 'me1) = (x : [`A of int | `B of 'me2] as 'me2);;

diff --git a/experimental/garrigue/varunion.ml b/experimental/garrigue/varunion.ml
new file mode 100644 (file)
index 0000000..30a410f
--- /dev/null
+++ b/experimental/garrigue/varunion.ml
@@ -0,0 +1,435 @@
+(* cvs update -r varunion parsing typing bytecomp toplevel *)
+
+type t = private [> ];;
+type u = private [> ] ~ [t];;
+type v = [t | u];;
+let f x = (x : t :> v);;
+
+(* bad *)
+module Mix(X: sig type t = private [> ] end)
+    (Y: sig type t = private [> ] end) =
+  struct type t = [X.t | Y.t] end;;
+
+(* bad *)
+module Mix(X: sig type t = private [> `A of int ] end)
+    (Y: sig type t = private [> `A of bool] ~ [X.t] end) =
+  struct type t = [X.t | Y.t] end;;
+
+(* ok *)
+module Mix(X: sig type t = private [> `A of int ] end)
+    (Y: sig type t = private [> `A of int] ~ [X.t] end) =
+  struct type t = [X.t | Y.t] end;;
+
+(* bad *)
+module Mix(X: sig type t = private [> `A of int ] end)
+    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+  struct type t = [X.t | Y.t] end;;
+
+type 'a t = private [> `L of 'a] ~ [`L];;
+
+(* ok *)
+module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
+    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+  struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
+
+module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
+    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
+  struct
+    type t = [X.t | Y.t]
+    let which = function #X.t -> `X | #Y.t -> `Y
+  end;;
+
+module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
+    (X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
+    (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
+  struct
+    type t = [X.t | Y.t]
+    let which = function #X.t -> `X | #Y.t -> `Y
+  end;;
+
+(* ok *)
+module M =
+  Mix(struct type t = [`C of char] end)
+    (struct type t = [`A of int | `C of char] end)
+    (struct type t = [`B of bool | `C of char] end);;
+
+(* bad *)
+module M =
+  Mix(struct type t = [`B of bool] end)
+    (struct type t = [`A of int | `B of bool] end)
+    (struct type t = [`B of bool | `C of char] end);;
+
+(* ok *)
+module M1 = struct type t = [`A of int | `C of char] end
+module M2 = struct type t = [`B of bool | `C of char] end
+module I = struct type t = [`C of char] end
+module M = Mix(I)(M1)(M2) ;;
+
+let c = (`C 'c' : M.t) ;;
+
+module M(X : sig type t = private [> `A] end) = 
+  struct let f (#X.t as x) = x end;;
+
+(* code generation *)
+type t = private [> `A ] ~ [`B];;
+match `B with #t -> 1 | `B -> 2;;
+
+module M : sig type t = private [> `A of int | `B] ~ [`C] end =
+  struct type t = [`A of int | `B | `D of bool] end;;
+let f = function (`C | #M.t) -> 1+1 ;;
+let f = function (`A _ | `B #M.t) -> 1+1 ;;
+
+(* expression *)
+module Mix(X:sig type t = private [> ] val show: t -> string end)
+    (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) =
+  struct
+    type t = [X.t | Y.t]
+    let show : t -> string = function
+        #X.t as x -> X.show x
+      | #Y.t as y -> Y.show y
+  end;;
+
+module EStr = struct
+  type t = [`Str of string]
+  let show (`Str s) = s
+end
+module EInt = struct
+  type t = [`Int of int]
+  let show (`Int i) = string_of_int i
+end
+module M = Mix(EStr)(EInt);;
+
+module type T = sig type t = private [> ] val show: t -> string end
+module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
+    T with type t = [X.t | Y.t] =
+  struct
+    type t = [X.t | Y.t]
+    let show = function
+        #X.t as x -> X.show x
+      | #Y.t as y -> Y.show y
+  end;;
+module M = Mix(EStr)(EInt);;
+
+(* deep *)
+module M : sig type t = private [> `A] end = struct type t = [`A] end
+module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
+
+(* bad *)
+type t = private [> ]
+type u = private [> `A of int] ~ [t] ;;
+
+(* ok *)
+type t = private [> `A of int]
+type u = private [> `A of int] ~ [t] ;;
+
+module F(X: sig
+  type t = private [> ] ~ [`A;`B;`C;`D]
+  type u = private [> `A|`B|`C] ~ [t; `D]
+end) : sig type v = private [< X.t | X.u | `D] end = struct
+  open X
+  let f = function #u -> 1 | #t -> 2 | `D -> 3
+  let g = function #u|#t|`D -> 2 
+  type v = [t|u|`D]
+end
+
+(* ok *)
+module M = struct type t = private [> `A] end;;
+module M' : sig type t = private [> ] ~ [`A] end = M;;
+
+(* ok *)
+module type T = sig type t = private [> ] ~ [`A] end;;
+module type T' = T with type t = private [> `A];;
+
+(* ok *)
+type t = private [> ] ~ [`A]
+let f = function `A x -> x | #t -> 0
+type t' = private [< `A of int | t];;
+
+(* should be ok *)
+module F(X:sig end) :
+    sig type t = private [> ] type u = private [> ] ~ [t] end =
+  struct type t = [ `A] type u = [`B] end
+module M = F(String)
+let f = function #M.t -> 1 | #M.u -> 2
+let f = function #M.t -> 1 | _ -> 2
+type t = [M.t | M.u]
+let f = function #t -> 1 | _ -> 2;;
+module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) =
+  struct let f = function #X.t -> 1 | _ -> 2 end;;
+module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;;
+module M1 = G(struct type t = M.t type u = M.u end) ;;
+(* bad *)
+let f = function #F(String).t -> 1 | _ -> 2;;
+type t = [F(String).t | M.u]
+let f = function #t -> 1 | _ -> 2;;
+module N : sig type t = private [> ] end =
+  struct type t = [F(String).t | M.u] end;;
+
+(* compatibility improvement *)
+type a = [`A of int | `B]
+type b = [`A of bool | `B]
+type c = private [> ] ~ [a;b]
+let f = function #c -> 1 | `A x -> truncate x
+type d = private [> ] ~ [a]
+let g = function #d -> 1 | `A x -> truncate x;;
+
+
+(* Expression Problem: functorial form *)
+
+type num = [ `Num of int ]
+
+module type Exp = sig
+  type t = private [> num]
+  val eval : t -> t
+  val show : t -> string
+end
+
+module Num(X : Exp) = struct
+  type t = num
+  let eval (`Num _ as x) : X.t = x
+  let show (`Num n) = string_of_int n
+end
+
+type 'a add = [ `Add of 'a * 'a ]
+
+module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
+  type t = X.t add
+  let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
+  let eval (`Add(e1, e2) : t) =
+    let e1 = X.eval e1 and e2 = X.eval e2 in
+    match e1, e2 with
+      `Num n1, `Num n2 -> `Num (n1+n2)
+    | `Num 0, e | e, `Num 0 -> e
+    | e12 -> `Add e12
+end 
+
+type 'a mul = [`Mul of 'a * 'a]
+
+module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
+  type t = X.t mul
+  let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
+  let eval (`Mul(e1, e2) : t) =
+    let e1 = X.eval e1 and e2 = X.eval e2 in
+    match e1, e2 with
+      `Num n1, `Num n2 -> `Num (n1*n2)
+    | `Num 0, e | e, `Num 0 -> `Num 0
+    | `Num 1, e | e, `Num 1 -> e
+    | e12 -> `Mul e12
+end
+
+module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
+  module type S =
+    sig
+      type t = private [> ] ~ [ X.t ]
+      val eval : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Dummy = struct type t = [`Dummy] end
+
+module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
+  struct
+    type t = [E1.t | E2.t]
+    let eval = function
+        #E1.t as x -> E1.eval x
+      | #E2.t as x -> E2.eval x
+    let show = function
+        #E1.t as x -> E1.show x
+      | #E2.t as x -> E2.show x
+  end
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+    Mix(EAdd)(Num(EAdd))(Add(EAdd))
+
+(* A bit heavy: one must pass E to everybody *)
+module rec E : Exp with type t = [num | E.t add | E.t mul] =
+    Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))
+
+let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
+
+(* Alternatives *)
+(* Direct approach, no need of Mix *)
+module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
+  struct
+    module E1 = Num(E)
+    module E2 = Add(E)
+    module E3 = Mul(E)
+    type t = E.t
+    let show = function
+      | #num as x -> E1.show x
+      | #add as x -> E2.show x
+      | #mul as x -> E3.show x
+    let eval = function
+      | #num as x -> E1.eval x
+      | #add as x -> E2.eval x
+      | #mul as x -> E3.eval x
+  end
+
+(* Do functor applications in Mix *)
+module type T = sig type t = private [> ] end
+module type Tnum = sig type t = private [> num] end
+
+module Ext(E : Tnum) = struct
+  module type S = functor (Y : Exp with type t = E.t) ->
+    sig
+      type t = private [> num]
+      val eval : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Ext'(E : Tnum)(X : T) = struct
+  module type S = functor (Y : Exp with type t = E.t) ->
+    sig
+      type t = private [> ] ~ [ X.t ]
+      val eval : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
+  struct
+    module E1 = F1(E)
+    module E2 = F2(E)
+    type t = [E1.t | E2.t]
+    let eval = function
+        #E1.t as x -> E1.eval x
+      | #E2.t as x -> E2.eval x
+    let show = function
+        #E1.t as x -> E1.show x
+      | #E2.t as x -> E2.show x
+  end
+
+module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
+    (E' : Exp with type t = E.t) =
+  Mix(E)(F1)(F2)
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+  Mix(EAdd)(Num)(Add)
+
+module rec EMul : (Exp with type t = [num | EMul.t mul]) =
+  Mix(EMul)(Num)(Mul)
+
+module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
+  Mix(E)(Join(E)(Num)(Add))(Mul)
+
+(* Linear extension by the end: not so nice *)
+module LExt(X : T) = struct
+  module type S =
+    sig
+      type t
+      val eval : t -> X.t
+      val show : t -> string
+    end
+end
+module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
+  struct
+    type t = [num | X.t]
+    let show = function
+        `Num n -> string_of_int n
+      | #X.t as x -> X.show x
+    let eval = function
+        #num as x -> x
+      | #X.t as x -> X.eval x
+  end
+module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
+    (X : LExt(E).S with type t = private [> ] ~ [add]) =
+  struct
+    type t = [E.t add | X.t]
+    let show = function
+        `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
+      | #X.t as x -> X.show x
+    let eval = function
+        `Add(e1,e2) ->
+          let e1 = E.eval e1 and e2 = E.eval e2 in
+          begin match e1, e2 with
+            `Num n1, `Num n2 -> `Num (n1+n2)
+          | `Num 0, e | e, `Num 0 -> e
+          | e12 -> `Add e12
+          end
+      | #X.t as x -> X.eval x
+  end
+module LEnd = struct
+  type t = [`Dummy]
+  let show `Dummy = ""
+  let eval `Dummy = `Dummy
+end
+module rec L : Exp with type t = [num | L.t add | `Dummy] =
+    LAdd(L)(LNum(L)(LEnd))
+
+(* Back to first form, but add map *)
+
+module Num(X : Exp) = struct
+  type t = num
+  let map f x = x
+  let eval1 (`Num _ as x) : X.t = x
+  let show (`Num n) = string_of_int n
+end
+
+module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
+  type t = X.t add
+  let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
+  let map f (`Add(e1, e2) : t) = `Add(f e1, f e2)
+  let eval1 (`Add(e1, e2) as e : t) =
+    match e1, e2 with
+      `Num n1, `Num n2 -> `Num (n1+n2)
+    | `Num 0, e | e, `Num 0 -> e
+    | _ -> e
+end 
+
+module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
+  type t = X.t mul
+  let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
+  let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2)
+  let eval1 (`Mul(e1, e2) as e : t) =
+    match e1, e2 with
+      `Num n1, `Num n2 -> `Num (n1*n2)
+    | `Num 0, e | e, `Num 0 -> `Num 0
+    | `Num 1, e | e, `Num 1 -> e
+    | _ -> e
+end
+
+module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
+  module type S =
+    sig
+      type t = private [> ] ~ [ X.t ]
+      val map  : (Y.t -> Y.t) -> t -> t
+      val eval1 : t -> Y.t
+      val show : t -> string
+    end
+end
+
+module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
+  struct
+    type t = [E1.t | E2.t]
+    let map f = function
+        #E1.t as x -> (E1.map f x : E1.t :> t)
+      | #E2.t as x -> (E2.map f x : E2.t :> t)
+    let eval1 = function
+        #E1.t as x -> E1.eval1 x
+      | #E2.t as x -> E2.eval1 x
+    let show = function
+        #E1.t as x -> E1.show x
+      | #E2.t as x -> E2.show x
+  end
+
+module type ET = sig
+  type t
+  val map  : (t -> t) -> t -> t
+  val eval1 : t -> t
+  val show : t -> string
+end
+
+module Fin(E : ET) = struct
+  include E
+  let rec eval e = eval1 (map eval e)
+end
+
+module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
+    Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd)))
+
+module rec E : Exp with type t = [num | E.t add | E.t mul] =
+    Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)))
+
+let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))

diff --git a/experimental/garrigue/with-module-type.diffs b/experimental/garrigue/with-module-type.diffs
new file mode 100644 (file)
index 0000000..c955b1f
--- /dev/null
+++ b/experimental/garrigue/with-module-type.diffs
@@ -0,0 +1,182 @@
+Index: parsing/parser.mly
+===================================================================
+--- parsing/parser.mly (revision 12005)
++++ parsing/parser.mly (working copy)
+@@ -1504,6 +1504,10 @@
+       { ($2, Pwith_module $4) }
+   | MODULE mod_longident COLONEQUAL mod_ext_longident
+       { ($2, Pwith_modsubst $4) }
++  | MODULE TYPE mod_longident EQUAL module_type
++      { ($3, Pwith_modtype $5) }
++  | MODULE TYPE mod_longident COLONEQUAL module_type
++      { ($3, Pwith_modtypesubst $5) }
+ ;
+ with_type_binder:
+     EQUAL          { Public }
+Index: parsing/parsetree.mli
+===================================================================
+--- parsing/parsetree.mli      (revision 12005)
++++ parsing/parsetree.mli      (working copy)
+@@ -239,6 +239,8 @@
+   | Pwith_module of Longident.t
+   | Pwith_typesubst of type_declaration
+   | Pwith_modsubst of Longident.t
++  | Pwith_modtype of module_type
++  | Pwith_modtypesubst of module_type
+ 
+ (* Value expressions for the module language *)
+ 
+Index: parsing/printast.ml
+===================================================================
+--- parsing/printast.ml        (revision 12005)
++++ parsing/printast.ml        (working copy)
+@@ -575,6 +575,12 @@
+       type_declaration (i+1) ppf td;
+   | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li;
+   | Pwith_modsubst (li) -> line i ppf "Pwith_modsubst %a\n" fmt_longident li;
++  | Pwith_modtype (mty) ->
++      line i ppf "Pwith_modtype\n";
++      module_type (i+1) ppf mty;
++  | Pwith_modtypesubst (mty) ->
++      line i ppf "Pwith_modtype\n";
++      module_type (i+1) ppf mty;
+ 
+ and module_expr i ppf x =
+   line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
+Index: typing/typemod.ml
+===================================================================
+--- typing/typemod.ml  (revision 12005)
++++ typing/typemod.ml  (working copy)
+@@ -74,6 +74,8 @@
+   : (Env.t -> Parsetree.module_expr -> module_type) ref
+   = ref (fun env m -> assert false)
+ 
++let transl_modtype_fwd = ref (fun env m -> assert false)
++
+ (* Merge one "with" constraint in a signature *)
+ 
+ let rec add_rec_types env = function
+@@ -163,6 +165,19 @@
+         ignore(Includemod.modtypes env newmty mty);
+         real_id := Some id;
+         make_next_first rs rem
++    | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
++      when Ident.name id = s ->
++        let mty = !transl_modtype_fwd initial_env pmty in
++        let mtd' = Tmodtype_manifest mty in
++        Includemod.modtype_declarations env id mtd' mtd;
++        Tsig_modtype(id, mtd') :: rem
++    | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
++      when Ident.name id = s ->
++        let mty = !transl_modtype_fwd initial_env pmty in
++        let mtd' = Tmodtype_manifest mty in
++        Includemod.modtype_declarations env id mtd' mtd;
++        real_id := Some id;
++        rem
+     | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
+       when Ident.name id = s ->
+         let newsg = merge env (extract_sig env loc mty) namelist None in
+@@ -200,6 +215,12 @@
+         let (path, _) = Typetexp.find_module initial_env loc lid in
+         let sub = Subst.add_module id path Subst.identity in
+         Subst.signature sub sg
++    | [s], Pwith_modtypesubst pmty ->
++        let id =
++          match !real_id with None -> assert false | Some id -> id in
++        let mty = !transl_modtype_fwd initial_env pmty in
++        let sub = Subst.add_modtype id mty Subst.identity in
++        Subst.signature sub sg
+     | _ ->
+         sg
+   with Includemod.Error explanation ->
+@@ -499,6 +520,8 @@
+   check_recmod_typedecls env2 sdecls dcl2;
+   (dcl2, env2)
+ 
++let () = transl_modtype_fwd := transl_modtype
++
+ (* Try to convert a module expression to a module path. *)
+ 
+ exception Not_a_path
+Index: typing/includemod.ml
+===================================================================
+--- typing/includemod.ml       (revision 12005)
++++ typing/includemod.ml       (working copy)
+@@ -326,10 +326,10 @@
+ 
+ (* Hide the context and substitution parameters to the outside world *)
+ 
+-let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
+-let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
+-let type_declarations env id decl1 decl2 =
+-  type_declarations env [] Subst.identity id decl1 decl2
++let modtypes env = modtypes env [] Subst.identity
++let signatures env = signatures env [] Subst.identity
++let type_declarations env = type_declarations env [] Subst.identity
++let modtype_declarations env = modtype_infos env [] Subst.identity
+ 
+ (* Error report *)
+ 
+Index: typing/includemod.mli
+===================================================================
+--- typing/includemod.mli      (revision 12005)
++++ typing/includemod.mli      (working copy)
+@@ -23,6 +23,8 @@
+ val compunit: string -> signature -> string -> signature -> module_coercion
+ val type_declarations:
+       Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
++val modtype_declarations:
++      Env.t -> Ident.t -> modtype_declaration -> modtype_declaration -> unit
+ 
+ type symptom =
+     Missing_field of Ident.t
+Index: testsuite/tests/typing-modules/Test.ml.reference
+===================================================================
+--- testsuite/tests/typing-modules/Test.ml.reference   (revision 12005)
++++ testsuite/tests/typing-modules/Test.ml.reference   (working copy)
+@@ -6,4 +6,12 @@
+ #       type -'a t
+ class type c = object method m : [ `A ] t end
+ #   module M : sig val v : (#c as 'a) -> 'a end
++#       module type S = sig module type T module F : functor (X : T) -> T end
++# module type T0 = sig type t end
++# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end
++# module type S2 = sig module F : functor (X : T0) -> T0 end
++# module type S3 =
++  sig
++    module F : functor (X : sig type t = int end) -> sig type t = int end
++  end
+ # 
+Index: testsuite/tests/typing-modules/Test.ml.principal.reference
+===================================================================
+--- testsuite/tests/typing-modules/Test.ml.principal.reference (revision 12005)
++++ testsuite/tests/typing-modules/Test.ml.principal.reference (working copy)
+@@ -6,4 +6,12 @@
+ #       type -'a t
+ class type c = object method m : [ `A ] t end
+ #   module M : sig val v : (#c as 'a) -> 'a end
++#       module type S = sig module type T module F : functor (X : T) -> T end
++# module type T0 = sig type t end
++# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end
++# module type S2 = sig module F : functor (X : T0) -> T0 end
++# module type S3 =
++  sig
++    module F : functor (X : sig type t = int end) -> sig type t = int end
++  end
+ # 
+Index: testsuite/tests/typing-modules/Test.ml
+===================================================================
+--- testsuite/tests/typing-modules/Test.ml     (revision 12005)
++++ testsuite/tests/typing-modules/Test.ml     (working copy)
+@@ -9,3 +9,11 @@
+ class type c = object method m : [ `A ] t end;;
+ module M : sig val v : (#c as 'a) -> 'a end =
+   struct let v x = ignore (x :> c); x end;;
++
++(* with module type *)
++
++module type S = sig module type T module F(X:T) : T end;;
++module type T0 = sig type t end;;
++module type S1 = S with module type T = T0;;
++module type S2 = S with module type T := T0;;
++module type S3 = S with module type T := sig type t = int end;;

diff --git a/lex/.cvsignore b/lex/.cvsignore
deleted file mode 100644 (file)
index 9f4f308..0000000
--- a/lex/.cvsignore
+++ /dev/null
@@ -1,6 +0,0 @@
-parser.ml
-parser.mli
-lexer.ml
-ocamllex
-ocamllex.opt
-parser.output

diff --git a/lex/.depend b/lex/.depend
index b51dbd3bdf4e52539b46a5768a8ce81ab9af3bfe..b0df0b874f006be945b756a23c5e701e950a6ae9 100644 (file)
--- a/lex/.depend
+++ b/lex/.depend
@@ -1,34 +1,34 @@
-common.cmi: syntax.cmi lexgen.cmi
-compact.cmi: lexgen.cmi
-cset.cmi:
-lexer.cmi: parser.cmi
-lexgen.cmi: syntax.cmi
-output.cmi: syntax.cmi lexgen.cmi compact.cmi common.cmi
-outputbis.cmi: syntax.cmi lexgen.cmi common.cmi
-parser.cmi: syntax.cmi
-syntax.cmi: cset.cmi
-table.cmi:
-common.cmo: syntax.cmi lexgen.cmi common.cmi
-common.cmx: syntax.cmx lexgen.cmx common.cmi
-compact.cmo: table.cmi lexgen.cmi compact.cmi
-compact.cmx: table.cmx lexgen.cmx compact.cmi
-cset.cmo: cset.cmi
-cset.cmx: cset.cmi
-lexer.cmo: syntax.cmi parser.cmi lexer.cmi
-lexer.cmx: syntax.cmx parser.cmx lexer.cmi
-lexgen.cmo: table.cmi syntax.cmi cset.cmi lexgen.cmi
-lexgen.cmx: table.cmx syntax.cmx cset.cmx lexgen.cmi
-main.cmo: syntax.cmi parser.cmi outputbis.cmi output.cmi lexgen.cmi lexer.cmi \
-    cset.cmi compact.cmi common.cmi
-main.cmx: syntax.cmx parser.cmx outputbis.cmx output.cmx lexgen.cmx lexer.cmx \
-    cset.cmx compact.cmx common.cmx
-output.cmo: syntax.cmi lexgen.cmi compact.cmi common.cmi output.cmi
-output.cmx: syntax.cmx lexgen.cmx compact.cmx common.cmx output.cmi
-outputbis.cmo: syntax.cmi lexgen.cmi common.cmi outputbis.cmi
-outputbis.cmx: syntax.cmx lexgen.cmx common.cmx outputbis.cmi
-parser.cmo: syntax.cmi cset.cmi parser.cmi
-parser.cmx: syntax.cmx cset.cmx parser.cmi
-syntax.cmo: cset.cmi syntax.cmi
-syntax.cmx: cset.cmx syntax.cmi
-table.cmo: table.cmi
-table.cmx: table.cmi
+common.cmi : syntax.cmi lexgen.cmi
+compact.cmi : lexgen.cmi
+cset.cmi :
+lexer.cmi : parser.cmi
+lexgen.cmi : syntax.cmi
+output.cmi : syntax.cmi lexgen.cmi compact.cmi common.cmi
+outputbis.cmi : syntax.cmi lexgen.cmi common.cmi
+parser.cmi : syntax.cmi
+syntax.cmi : cset.cmi
+table.cmi :
+common.cmo : syntax.cmi lexgen.cmi common.cmi
+common.cmx : syntax.cmx lexgen.cmx common.cmi
+compact.cmo : table.cmi lexgen.cmi compact.cmi
+compact.cmx : table.cmx lexgen.cmx compact.cmi
+cset.cmo : cset.cmi
+cset.cmx : cset.cmi
+lexer.cmo : syntax.cmi parser.cmi lexer.cmi
+lexer.cmx : syntax.cmx parser.cmx lexer.cmi
+lexgen.cmo : table.cmi syntax.cmi cset.cmi lexgen.cmi
+lexgen.cmx : table.cmx syntax.cmx cset.cmx lexgen.cmi
+main.cmo : syntax.cmi parser.cmi outputbis.cmi output.cmi lexgen.cmi \
+    lexer.cmi cset.cmi compact.cmi common.cmi
+main.cmx : syntax.cmx parser.cmx outputbis.cmx output.cmx lexgen.cmx \
+    lexer.cmx cset.cmx compact.cmx common.cmx
+output.cmo : syntax.cmi lexgen.cmi compact.cmi common.cmi output.cmi
+output.cmx : syntax.cmx lexgen.cmx compact.cmx common.cmx output.cmi
+outputbis.cmo : syntax.cmi lexgen.cmi common.cmi outputbis.cmi
+outputbis.cmx : syntax.cmx lexgen.cmx common.cmx outputbis.cmi
+parser.cmo : syntax.cmi cset.cmi parser.cmi
+parser.cmx : syntax.cmx cset.cmx parser.cmi
+syntax.cmo : cset.cmi syntax.cmi
+syntax.cmx : cset.cmx syntax.cmi
+table.cmo : table.cmi
+table.cmx : table.cmi

diff --git a/lex/.ignore b/lex/.ignore
new file mode 100644 (file)
index 0000000..9f4f308
--- /dev/null
+++ b/lex/.ignore
@@ -0,0 +1,6 @@
+parser.ml
+parser.mli
+lexer.ml
+ocamllex
+ocamllex.opt
+parser.output

diff --git a/lex/Makefile b/lex/Makefile
index f190ed89255c926f1a7d718c65037569652b2074..d73939a3c163964bde40abd96968c1a6aa6d83cd 100644 (file)
--- a/lex/Makefile
+++ b/lex/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/lex/Makefile.nt b/lex/Makefile.nt
index cb1ef94a5dffc853feb640ecd1905ad5de1b9659..8443c575989d94f5a31d977d4fe71f6635583c49 100644 (file)
--- a/lex/Makefile.nt
+++ b/lex/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/lex/common.ml b/lex/common.ml
index cacea62d05e606f1e3a88762879dbd26ad3a795e..5638185d0b74d2ffb79772db20b151f61a7cf0cf 100644 (file)
--- a/lex/common.ml
+++ b/lex/common.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Luc Maranget, projet Moscova,                            *)
 (*                         INRIA Rocquencourt                          *)

diff --git a/lex/common.mli b/lex/common.mli
index e5742b45b24e39c4f347d51711fd3aae63315d42..f85baa01f8f135ae2f53b6186e9813562f27985e 100644 (file)
--- a/lex/common.mli
+++ b/lex/common.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Damien Doligez, projet Moscova, INRIA Rocquencourt          *)
 (*                                                                     *)

diff --git a/lex/compact.ml b/lex/compact.ml
index abbf5a5036dc9412f0da34d78e227c67de1dab63..72cfd9e7c827d4f3e142ad811b76952b06a8845e 100644 (file)
--- a/lex/compact.ml
+++ b/lex/compact.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/compact.mli b/lex/compact.mli
index 18363c3d4d40ce7b4f5154cf7a0dae1af249ff2d..6e48df00654c1c01b2f9744e32b25bddd33b8ffe 100644 (file)
--- a/lex/compact.mli
+++ b/lex/compact.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/cset.ml b/lex/cset.ml
index c4594540ece24385f2c4974b33d7035e5c5a716d..ce77044b69aff19e9d13b7bc445eaa746ea7e0ff 100644 (file)
--- a/lex/cset.ml
+++ b/lex/cset.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Luc Maranget, Jerome Vouillon projet Cristal,            *)
 (*                         INRIA Rocquencourt                          *)

diff --git a/lex/cset.mli b/lex/cset.mli
index 53b58995914d4ff874664dc68d9e5a76d3c5d62f..b30c3b67188fbd3d5cea7d72f6c8ee3d81131039 100644 (file)
--- a/lex/cset.mli
+++ b/lex/cset.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Luc Maranget, Jerome Vouillon projet Cristal,            *)
 (*                         INRIA Rocquencourt                          *)

diff --git a/lex/lexer.mli b/lex/lexer.mli
index be34674eb3855f32fbbbedd53455692a73f3e36a..5097d30943e8e9bcd1ff8e8560d35c676494be9f 100644 (file)
--- a/lex/lexer.mli
+++ b/lex/lexer.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/lexer.mll b/lex/lexer.mll
index b72804287e4da2b45783d0c4d8436c1c19442d70..b99dddf9e0a435e729b767f929b69c25b848f9a6 100644 (file)
--- a/lex/lexer.mll
+++ b/lex/lexer.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/lexgen.ml b/lex/lexgen.ml
index 775e78b0563ce507a66efdf36991ea1761227def..37720be6122ba31aa128727dfeac90159fa4bbc0 100644 (file)
--- a/lex/lexgen.ml
+++ b/lex/lexgen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal,                            *)
 (*            Luc Maranget, projet Moscova,                            *)

diff --git a/lex/lexgen.mli b/lex/lexgen.mli
index 5136f8f28300792e7ccd4e8b5c4f43c3e3b01470..155b9e45a0f77cad77daf8ad9518494aeaeea4bc 100644 (file)
--- a/lex/lexgen.mli
+++ b/lex/lexgen.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/main.ml b/lex/main.ml
index 57b404904c5f1c65e200432defe60dae79416a49..28f1e55e62849fcd28af4ea3946bed90e90dd678 100644 (file)
--- a/lex/main.ml
+++ b/lex/main.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,7 +24,7 @@ let output_name = ref None
 let usage = "usage: ocamlex [options] sourcefile"
 
 let print_version_string () =
-  print_string "The Objective Caml lexer generator, version ";
+  print_string "The OCaml lexer generator, version ";
   print_string Sys.ocaml_version ; print_newline();
   exit 0
 

diff --git a/lex/output.ml b/lex/output.ml
index 5ca403b52dd03b52241506d8f62a5f1071ff3f54..377c00a2dd16188cd846d217ff200f808a623ee4 100644 (file)
--- a/lex/output.ml
+++ b/lex/output.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/output.mli b/lex/output.mli
index 85f89b30cec391e2ad79f6961cdf58eb8d43e085..5eae103143b7fc79072af8ec3bd2b0caec84071f 100644 (file)
--- a/lex/output.mli
+++ b/lex/output.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/outputbis.ml b/lex/outputbis.ml
index 6d5e77c30d4fa9c4c7e1778406d2191c320ac759..7eac3544447c0938a2237af96b2e50a6574fc5ac 100644 (file)
--- a/lex/outputbis.ml
+++ b/lex/outputbis.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/outputbis.mli b/lex/outputbis.mli
index 76f00672bfa55c8ec1a0f738d18a1afb19b64eb2..df6bf9600a7e926a028841ee767624426cc3b9d7 100644 (file)
--- a/lex/outputbis.mli
+++ b/lex/outputbis.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Luc Maranget projet Moscova INRIA Rocquencourt           *)
 (*                                                                     *)

diff --git a/lex/parser.mly b/lex/parser.mly
index 9bc0906afd8083dc06d8ff1b05cfa46f9137b7ba..c36d8e020209c683eda4885ad00903dbf6fac6ec 100644 (file)
--- a/lex/parser.mly
+++ b/lex/parser.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/lex/syntax.ml b/lex/syntax.ml
index d1daa02dbd93bc64f23255f8b4e977c5e41e9db0..746a99a241cb46b9e49de65a1acc3cccf669305b 100644 (file)
--- a/lex/syntax.ml
+++ b/lex/syntax.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/syntax.mli b/lex/syntax.mli
index 4864b50ee9421a068a403efd984947e7d93be5a9..d61fdb228e82ab8510b31a001fcddcb15e6fd451 100644 (file)
--- a/lex/syntax.mli
+++ b/lex/syntax.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/table.ml b/lex/table.ml
index 402f52be8b39ccb5051c196cf0ad93ee7a5c25a7..fb5a6128eb68b7dce30fd84a943544b5b740722a 100644 (file)
--- a/lex/table.ml
+++ b/lex/table.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Luc Maranget, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/lex/table.mli b/lex/table.mli
index b88d7d345419f77e146e72ea71e342b90ef2fc7b..8d9938cbff759bdb1cfb7e76e0f3230fb2d38f3d 100644 (file)
--- a/lex/table.mli
+++ b/lex/table.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Luc Maranget, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/man/Makefile b/man/Makefile
index 4753c202ea831f94bd4f405bd6ba48984113abff..4c0cb819143742e3c2403d5442ae3c62ee116fe0 100644 (file)
--- a/man/Makefile
+++ b/man/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -20,3 +20,4 @@ install:
        for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done
        echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' > $(DIR)/ocamlc.opt.$(MANEXT)
        echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' > $(DIR)/ocamlopt.opt.$(MANEXT)
+       echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' > $(DIR)/ocamloptp.$(MANEXT)

diff --git a/man/ocaml.m b/man/ocaml.m
index f8ca062d0c083c49f7fc3cacdb73b85a9a7c05d2..c230038c20289430b8771819a93e77332383639a 100644 (file)
--- a/man/ocaml.m
+++ b/man/ocaml.m
@@ -1,9 +1,21 @@
-\" $Id$
-
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAML 1
 
 .SH NAME
-ocaml \- The Objective Caml interactive toplevel
+ocaml \- The OCaml interactive toplevel
 
 .SH SYNOPSIS
 .B ocaml
@@ -20,9 +32,9 @@ ocaml \- The Objective Caml interactive toplevel
 
 The
 .BR ocaml (1)
-command is the toplevel system for Objective Caml,
-that permits interactive use of the Objective Caml system through a
-read-eval-print loop. In this mode, the system repeatedly reads Caml
+command is the toplevel system for OCaml,
+that permits interactive use of the OCaml system through a
+read-eval-print loop. In this mode, the system repeatedly reads OCaml
 phrases from the input, then typechecks, compiles and evaluates
 them, then prints the inferred type and result value, if any. The
 system prints a # (sharp) prompt before reading each phrase.
@@ -102,6 +114,14 @@ applications, and parameter order becomes strict.
 .B \-noprompt
 Do not display any prompt when waiting for input.
 .TP
+.B \-nopromptcont
+Do not display the secondary prompt when waiting for continuation lines in
+multi-line inputs.  This should be used e.g. when running
+.BR ocaml (1)
+in an
+.BR emacs (1)
+window.
+.TP
 .B \-nostdlib
 Do not include the standard library directory in the list of
 directories searched for source and compiled files.
@@ -178,5 +198,5 @@ and look up its capabilities in the terminal database.
 .SH SEE ALSO
 .BR ocamlc (1), \ ocamlopt (1), \ ocamlrun (1).
 .br
-.IR The\ Objective\ Caml\ user's\ manual ,
+.IR The\ OCaml\ user's\ manual ,
 chapter "The toplevel system".

diff --git a/man/ocamlc.m b/man/ocamlc.m
index 20cd06ef0e1147d79866e0b2b4403a398fc6e02a..c26d29ca54a28d290346143eb3343e1aacefe8ba 100644 (file)
--- a/man/ocamlc.m
+++ b/man/ocamlc.m
@@ -1,9 +1,21 @@
-\" $Id$
-
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLC 1
 
 .SH NAME
-ocamlc \- The Objective Caml bytecode compiler
+ocamlc \- The OCaml bytecode compiler
 
 .SH SYNOPSIS
 .B ocamlc
@@ -20,9 +32,9 @@ ocamlc \- The Objective Caml bytecode compiler
 
 .SH DESCRIPTION
 
-The Objective Caml bytecode compiler
+The OCaml bytecode compiler
 .BR ocamlc (1)
-compiles Caml source files to bytecode object files and links
+compiles OCaml source files to bytecode object files and links
 these object files to produce standalone bytecode executable files.
 These executable files are then run by the bytecode interpreter
 .BR ocamlrun (1).
@@ -78,7 +90,7 @@ the implementation
 
 Arguments ending in .cmo are taken to be compiled object bytecode.  These
 files are linked together, along with the object files obtained
-by compiling .ml arguments (if any), and the Caml Light standard
+by compiling .ml arguments (if any), and the OCaml standard
 library, to produce a standalone executable program. The order in
 which .cmo and.ml arguments are presented on the command line is
 relevant: compilation units are initialized in that order at
@@ -117,14 +129,14 @@ below).
 
 Arguments ending in .so
 are assumed to be C shared libraries (DLLs).  During linking, they are
-searched for external C functions referenced from the Caml code,
+searched for external C functions referenced from the OCaml code,
 and their names are written in the generated bytecode executable.
 The run-time system
 .BR ocamlrun (1)
 then loads them dynamically at program start-up time.
 
 The output of the linking phase is a file containing compiled bytecode
-that can be executed by the Objective Caml bytecode interpreter:
+that can be executed by the OCaml bytecode interpreter:
 the command
 .BR ocamlrun (1).
 If
@@ -158,7 +170,7 @@ Thus, it behaves exactly like
 .BR ocamlc ,
 but compiles faster.
 .B ocamlc.opt
-may not be available in all installations of Objective Caml.
+may not be available in all installations of OCaml.
 
 .SH OPTIONS
 
@@ -196,6 +208,11 @@ file can be used with the emacs commands given in
 .B emacs/caml\-types.el
 to display types and other annotations interactively.
 .TP
+.B \-dtypes
+Has been deprecated. Please use 
+.BI \-annot 
+instead.
+.TP
 .B \-c
 Compile only. Suppress the linking phase of the
 compilation. Source code files are turned into compiled files, but no
@@ -242,7 +259,7 @@ and the bytecode for the program. The resulting file is larger, but it
 can be executed directly, even if the
 .BR ocamlrun (1)
 command is not
-installed. Moreover, the "custom runtime" mode enables linking Caml
+installed. Moreover, the "custom runtime" mode enables linking OCaml
 code with user-defined C functions.
 
 Never use the
@@ -389,10 +406,9 @@ specify the name of the output file produced.
 .TP
 .B \-output\-obj
 Cause the linker to produce a C object file instead of a bytecode
-executable file. This is useful to wrap Caml code as a C library,
-callable from any C program. The name of the output object file is
-.B camlprog.o
-by default; it can be set with the
+executable file. This is useful to wrap OCaml code as a C library,
+callable from any C program. The name of the output object file 
+must be set with the
 .B \-o
 option. This
 option can also be used to produce a C source file (.c extension) or
@@ -444,10 +460,23 @@ only recursive types where the recursion goes through an object type
 are supported. Note that once you have created an interface using this
 flag, you must use it again for all dependencies.
 .TP
+.BI \-runtime\-variant \ suffix
+Add
+.I suffix
+to the name of the runtime library that will be used by the program.
+If OCaml was configured with option
+.BR \-with\-debug\-runtime ,
+then the
+.B d
+suffix is supported and gives a debug version of the runtime.
+.TP
+.B \-strict\-sequence
+The left-hand part of a sequence must have type unit.
+.TP
 .B \-thread
 Compile or link multithreaded programs, in combination with the
 system "threads" library described in
-.IR The\ Objective\ Caml\ user's\ manual .
+.IR The\ OCaml\ user's\ manual .
 .TP
 .B \-unsafe
 Turn bound checking off for array and string accesses (the
@@ -476,14 +505,14 @@ invocations of the C compiler and linker in
 .B \-custom
 mode.  Useful to debug C library problems.
 .TP
-.BR \-vnum or \-version
+.BR \-vnum \ or\  \-version
 Print the version number of the compiler in short form (e.g. "3.11.0"),
 then exit.
 .TP
 .B \-vmthread
 Compile or link multithreaded programs, in combination with the
 VM-level threads library described in
-.IR The\ Objective\ Caml\ user's\ manual .
+.IR The\ OCaml\ user's\ manual .
 .TP
 .BI \-w \ warning\-list
 Enable, disable, or mark as errors the warnings specified by the argument
@@ -518,6 +547,27 @@ between them.  A warning specifier is one of the following:
 \ \ Enable and mark warning number
 .IR num .
 
+.BI + num1 .. num2
+\ \ Enable all warnings between
+.I num1
+and
+.I num2
+(inclusive).
+
+.BI \- num1 .. num2
+\ \ Disable all warnings between
+.I num1
+and
+.I num2
+(inclusive).
+
+.BI @ num1 .. num2
+\ \ Enable and mark all warnings between
+.I num1
+and
+.I num2
+(inclusive).
+
 .BI + letter
 \ \ Enable the set of warnings corresponding to
 .IR letter .
@@ -565,7 +615,7 @@ function type and is ignored.
 \ \ \ Label omitted in function application.
 
 7
-\ \ \ Some methods are overridden in the class where they are defined.
+\ \ \ Method overridden without using the "override" keyword
 
 8
 \ \ \ Partial match: missing cases in pattern-matching.
@@ -642,7 +692,6 @@ pattern.
 
 29
 \ \ A non-escaped end-of-line was found in a string constant.  This may
-
 cause portability problems between Unix and Windows.
 
 The letters stand for the following sets of warnings.  Any letter not
@@ -663,6 +712,9 @@ mentioned here corresponds to the empty set.
 .B F
 \ 5
 
+.B K
+\ 32, 33, 34, 35, 36, 37
+
 .B L
 \ 6
 
@@ -685,7 +737,7 @@ mentioned here corresponds to the empty set.
 \ 13
 
 .B X
-\ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25
+\ 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 30
 
 .B Y
 \ 26
@@ -695,7 +747,7 @@ mentioned here corresponds to the empty set.
 
 .IP
 The default setting is
-.BR \-w\ +a\-4\-6\-9\-27\-28\-29 .
+.BR \-w\ +a\-4\-6\-9\-27\-29\-32..37 .
 Note that warnings
 .BR 5 \ and \ 10
 are not always triggered, depending on the internals of the type checker.
@@ -717,14 +769,14 @@ sign (or a lowercase letter) turns them back into warnings, and a
 .B @
 sign both enables and marks the corresponding warnings.
 
-Note: it is not recommended to use warning sets (i.e. letters) as
-arguments to
+Note: it is not recommended to use the
 .B \-warn\-error
-in production code, because this can break your build when future versions
-of OCaml add some new warnings.
+option in production code, because it will almost certainly prevent
+compiling your program with later versions of OCaml when they add new
+warnings.
 
 The default setting is
-.B \-warn\-error\ +a
+.B \-warn\-error\ -a
 (none of the warnings is treated as an error).
 .TP
 .B \-where
@@ -741,5 +793,5 @@ Display a short usage summary and exit.
 .SH SEE ALSO
 .BR ocamlopt (1), \ ocamlrun (1), \ ocaml (1).
 .br
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "Batch compilation".

diff --git a/man/ocamlcp.m b/man/ocamlcp.m
index d3559ad308f07acbd1d6ef5821364846101865cb..10077e12838cbe8c9dd0e0fa6305abe0dbf3d53d 100644 (file)
--- a/man/ocamlcp.m
+++ b/man/ocamlcp.m
@@ -1,9 +1,21 @@
-\" $Id$
-
-.TH OCAMLCP 1
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
+.TH "OCAMLCP" 1
 
 .SH NAME
-ocamlcp \- The Objective Caml profiling compiler
+ocamlcp, ocamloptp \- The OCaml profiling compilers
 
 .SH SYNOPSIS
 .B ocamlcp
@@ -11,36 +23,62 @@ ocamlcp \- The Objective Caml profiling compiler
 .I ocamlc options
 ]
 [
-.BI \-p \ flags
+.BI \-P \ flags
+]
+.I filename ...
+
+.B ocamloptp
+[
+.I ocamlopt options
+]
+[
+.BI \-P \ flags
 ]
 .I filename ...
 
 .SH DESCRIPTION
 The
 .B ocamlcp
-command is a front-end to
+and
+.B ocamloptp
+commands are front-ends to
 .BR ocamlc (1)
-that instruments the source code, adding code to record how many times
-functions are called, branches of conditionals are taken, ...
+and
+.BR ocamlopt (1)
+that instrument the source code, adding code to record how many times
+functions are called, branches of conditionals are taken, etc.
 Execution of instrumented code produces an execution profile in the
 file ocamlprof.dump, which can be read using
 .BR ocamlprof (1).
 
 .B ocamlcp
 accepts the same arguments and options as
-.BR ocamlc (1).
+.BR ocamlc (1)
+and
+.B ocamloptp
+accepts the same arguments and options as
+.BR ocamlopt (1).
+There is only one exception: in both cases, the
+.B \-pp
+option is not supported.  If you need to preprocess your source files,
+you will have to do it separately before calling
+.B ocamlcp
+or
+.BR ocamloptp .
 
 .SH OPTIONS
 
 In addition to the
 .BR ocamlc (1)
+or
+.BR ocamlopt (1)
 options,
 .B ocamlcp
-accepts the following option controlling the amount of profiling
-information:
-.TP
-.BI \-p \ letters
-The
+and
+.B ocamloptp
+accept one option to control the kind of profiling information, the
+.BI \-P \ letters
+option. The
 .I letters
 indicate which parts of the program should be profiled:
 .TP
@@ -72,28 +110,32 @@ branch of an exception catcher
 
 .PP
 For instance, compiling with
-.B ocamlcp\ \-pfilm
+.B ocamlcp \-P film
 profiles function calls,
 .BR if \ ... \ then \ ... \ else \ ...,
 loops, and pattern matching.
 
 Calling
 .BR ocamlcp (1)
+or
+.BR ocamloptp (1)
 without the
-.B \-p
+.B \-P
 option defaults to
-.B \-p\ fm
+.BR \-P\ fm ,
 meaning that only function calls and pattern matching are profiled.
 
-Note: due to the implementation of streams and stream patterns as
-syntactic sugar, it is hard to predict what parts of stream expressions
-and patterns will be profiled by a given flag.  To profile a program with
-streams, we recommend using
-.BR ocamlcp\ \-p\ a .
+Note: for compatibility with previous versions,
+.BR ocamlcp (1)
+also accepts the option
+.B \-p
+with the same argument and meaning as
+.BR \-P .
 
 .SH SEE ALSO
 .BR ocamlc (1),
+.BR ocamlopt (1),
 .BR ocamlprof (1).
 .br
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "Profiling".

diff --git a/man/ocamldebug.m b/man/ocamldebug.m
index d527fe870acd438ab9d1086444e5c39ee3701c58..0eceeba3b8f628ebc8d3ab850da06dfa257a9642 100644 (file)
--- a/man/ocamldebug.m
+++ b/man/ocamldebug.m
@@ -1,15 +1,27 @@
-\" $Id$
-
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 2001 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLDEBUG 1
 
 .SH NAME
-ocamldebug \- the Objective Caml source-level replay debugger.
+ocamldebug \- the OCaml source-level replay debugger.
 .SH SYNOPSIS
 .B ocamldebug
 .RI [\  options \ ]\  program \ [\  arguments \ ]
 .SH DESCRIPTION
 .B ocamldebug
-is the Objective Caml source-level replay debugger.
+is the OCaml source-level replay debugger.
 
 Before the debugger can be used, the program must be compiled and
 linked with the
@@ -46,7 +58,7 @@ command.)
 .TP
 .B \-emacs
 Tell the debugger it is executed under Emacs.  (See
-.I "The Objective Caml user's manual"
+.I "The OCaml user's manual"
 for information on how to run the debugger under Emacs.)
 .TP
 .BI \-I \ directory
@@ -64,7 +76,7 @@ for communicating with the debugged program. See the description
 of the command
 .B set\ socket
 in
-.I "The Objective Caml user's manual"
+.I "The OCaml user's manual"
 for the format of
 .IR socket .
 .TP
@@ -79,7 +91,7 @@ Display a short usage summary and exit.
 .SH SEE ALSO
 .BR ocamlc (1)
 .br
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "The debugger".
 .SH AUTHOR
 This manual page was written by Sven LUTHER <luther@debian.org>,

diff --git a/man/ocamldep.m b/man/ocamldep.m
index 521e41bbceca7c52aa7049ee1cc7667b17884ab2..be1e7348ef5df93415d2b87bb525a7ccd8d7ae2f 100644 (file)
--- a/man/ocamldep.m
+++ b/man/ocamldep.m
@@ -1,9 +1,21 @@
-\" $Id$
-
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLDEP 1
 
 .SH NAME
-ocamldep \- Dependency generator for Objective Caml
+ocamldep \- Dependency generator for OCaml
 
 .SH SYNOPSIS
 .B ocamldep
@@ -16,7 +28,7 @@ ocamldep \- Dependency generator for Objective Caml
 
 The
 .BR ocamldep (1)
-command scans a set of Objective Caml source files
+command scans a set of OCaml source files
 (.ml and .mli files) for references to external compilation units,
 and outputs dependency lines in a format suitable for the
 .BR make (1)
@@ -117,5 +129,5 @@ Display a short usage summary and exit.
 .BR ocamlc (1),
 .BR ocamlopt (1).
 .br
-.IR The\ Objective\ Caml\ user's\ manual ,
+.IR The\ OCaml\ user's\ manual ,
 chapter "Dependency generator".

diff --git a/man/ocamldoc.m b/man/ocamldoc.m
index 5c217cfa62194f05af97b23afd191c51f088e33e..32d6aae1c1edc9995992cd9ececa4622837cea26 100644 (file)
--- a/man/ocamldoc.m
+++ b/man/ocamldoc.m
@@ -1,5 +1,17 @@
-\" $Id$
-
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *
+.\"*                                                                     *
+.\"*  Copyright 2004 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLDOC 1
 
 \" .de Sh \" Subsection heading
@@ -12,7 +24,7 @@
 \" ..
 
 .SH NAME
-ocamldoc \- The Objective Caml documentation generator
+ocamldoc \- The OCaml documentation generator
 
 
 .SH SYNOPSIS
@@ -24,15 +36,18 @@ ocamldoc \- The Objective Caml documentation generator
 
 .SH DESCRIPTION
 
-The Objective Caml documentation generator
+The OCaml documentation generator
 .BR ocamldoc (1)
 generates documentation from special comments embedded in source files. The
-comments used by OCamldoc are of the form
+comments used by
+.B ocamldoc
+are of the form
 .I (** ... *)
 and follow the format described in the
-.IR "The Objective Caml user's manual" .
+.IR "The OCaml user's manual" .
 
-OCamldoc can produce documentation in various formats: HTML, LaTeX, TeXinfo,
+.B ocamldoc
+can produce documentation in various formats: HTML, LaTeX, TeXinfo,
 Unix man pages, and
 .BR dot (1)
 dependency graphs. Moreover, users can add their own
@@ -112,7 +127,9 @@ to display it.
 Dynamically load the given file (which extension usually is .cmo or .cma),
 which defines a custom documentation generator.
 If the given file is a simple one and does not exist in
-the current directory, then ocamldoc looks for it in the custom
+the current directory, then
+.B ocamldoc
+looks for it in the custom
 generators default directory, and in the directories specified with the
 .B \-i
 option.
@@ -236,7 +253,9 @@ as the title for the generated documentation.
 .BI \-intro \ file
 Use content of
 .I file
-as ocamldoc text to use as introduction (HTML, LaTeX and TeXinfo only).
+as 
+.B ocamldoc
+text to use as introduction (HTML, LaTeX and TeXinfo only).
 For HTML, the file is used to create the whole "index.html" file.
 .TP
 .B \-v
@@ -249,16 +268,20 @@ Print version string and exit.
 Print short version number and exit.
 .TP
 .B \-warn\-error
-Treat Ocamldoc warnings as errors.
+Treat
+.B ocamldoc
+warnings as errors.
 .TP
 .B \-hide\-warnings
-Do not print OCamldoc warnings.
+Do not print
+.B ocamldoc
+warnings.
 .TP
 .BR \-help \ or \ \-\-help
 Display a short usage summary and exit.
 .SS "Type-checking options"
 .BR ocamldoc (1)
-calls the Objective Caml type-checker to obtain type information. The
+calls the OCaml type-checker to obtain type information. The
 following options impact the type-checking phase. They have the same meaning
 as for the
 .BR ocamlc (1)\ and \ ocamlopt (1)
@@ -430,5 +453,5 @@ Set the section number used for generated man filenames. Default is 3.
 .BR ocamlc (1),
 .BR ocamlopt (1).
 .br
-.IR "The Objective Caml user's manual",
+.IR "The OCaml user's manual",
 chapter "The documentation generator".

diff --git a/man/ocamllex.m b/man/ocamllex.m
index e117dc474b65b683f615d67dc660d43e54ddb8fa..314af516cb21d75700fb227529d86ee75b6066af 100644 (file)
--- a/man/ocamllex.m
+++ b/man/ocamllex.m
@@ -1,8 +1,21 @@
-\" $Id$
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLLEX 1
 
 .SH NAME
-ocamllex \- The Objective Caml lexer generator
+ocamllex \- The OCaml lexer generator
 
 .SH SYNOPSIS
 .B ocamllex
@@ -18,7 +31,7 @@ ocamllex \- The Objective Caml lexer generator
 
 The
 .BR ocamllex (1)
-command generates Objective Caml lexers from a set of regular
+command generates OCaml lexers from a set of regular
 expressions with associated semantic actions, in the style of
 .BR lex (1).
 
@@ -26,7 +39,7 @@ Running
 .BR ocamllex (1)
 on the input file
 .IR lexer \&.mll
-produces Caml code for a lexical analyzer in file
+produces OCaml code for a lexical analyzer in file
 .IR lexer \&.ml.
 
 This file defines one lexing function per entry point in the lexer
@@ -53,7 +66,7 @@ command recognizes the following options:
 .TP
 .B \-ml
 Output code that does not use OCaml's built-in automata
-interpreter. Instead, the automaton is encoded by Caml functions.
+interpreter. Instead, the automaton is encoded by OCaml functions.
 This option is mainly useful for debugging
 .BR ocamllex (1),
 using it for production lexers is not recommended.
@@ -83,5 +96,5 @@ Display a short usage summary and exit.
 .SH SEE ALSO
 .BR ocamlyacc (1).
 .br
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "Lexer and parser generators".

diff --git a/man/ocamlmktop.m b/man/ocamlmktop.m
index d84381e154f860cbd66851e85421fed59f2d2fee..f9c014c543e78ac474d0c81efd525070327bd594 100644 (file)
--- a/man/ocamlmktop.m
+++ b/man/ocamlmktop.m
@@ -1,4 +1,17 @@
-\" $Id$
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1999 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLMKTOP 1
 
 .SH NAME
@@ -29,7 +42,7 @@ ocamlmktop \- Building custom toplevel systems
 
 The
 .BR ocamlmktop (1)
-command builds Objective Caml toplevels that
+command builds OCaml toplevels that
 contain user code preloaded at start-up.
 The
 .BR ocamlmktop (1)
@@ -37,8 +50,8 @@ command takes as argument a set of
 .IR x .cmo
 and
 .IR x .cma
-files, and links them with the object files that implement the Objective
-Caml toplevel.  If the
+files, and links them with the object files that implement the
+OCaml toplevel.  If the
 .B \-custom
 flag is given, C object files and libraries (.o and .a files) can also
 be given on the command line and are linked in the resulting toplevel.

diff --git a/man/ocamlopt.m b/man/ocamlopt.m
index c021fab6e80c13febc1909e15b1f24bea72adcc4..0dfb196bd67772ccd762d8dbd9d7da711b8250c7 100644 (file)
--- a/man/ocamlopt.m
+++ b/man/ocamlopt.m
@@ -1,10 +1,22 @@
-\" $Id$
-
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLOPT 1
 
 .SH NAME
 
-ocamlopt \- The Objective Caml native-code compiler
+ocamlopt \- The OCaml native-code compiler
 
 .SH SYNOPSIS
 
@@ -19,10 +31,10 @@ ocamlopt \- The Objective Caml native-code compiler
 
 .SH DESCRIPTION
 
-The Objective Caml high-performance
+The OCaml high-performance
 native-code compiler
 .BR ocamlopt (1)
-compiles Caml source files to native code object files and link these
+compiles OCaml source files to native code object files and link these
 object files to produce standalone executables.
 
 The
@@ -65,7 +77,7 @@ should always be referred to under the name
 .IR x .cmx
 (when given a .o file,
 .BR ocamlopt (1)
-assumes that it contains code compiled from C, not from Caml).
+assumes that it contains code compiled from C, not from OCaml).
 
 The implementation is checked against the interface file
 .IR x .mli
@@ -74,7 +86,7 @@ The implementation is checked against the interface file
 
 Arguments ending in .cmx are taken to be compiled object code.  These
 files are linked together, along with the object files obtained
-by compiling .ml arguments (if any), and the Caml Light standard
+by compiling .ml arguments (if any), and the OCaml standard
 library, to produce a native-code executable program. The order in
 which .cmx and .ml arguments are presented on the command line is
 relevant: compilation units are initialized in that order at
@@ -120,7 +132,7 @@ Thus, it behaves exactly like
 .BR ocamlopt ,
 but compiles faster.
 .B ocamlopt.opt
-is not available in all installations of Objective Caml.
+is not available in all installations of OCaml.
 
 .SH OPTIONS
 
@@ -158,6 +170,11 @@ file can be used with the emacs commands given in
 .B emacs/caml\-types.el
 to display types and other annotations interactively.
 .TP
+.B \-dtypes
+Has been deprecated. Please use 
+.BI \-annot 
+instead.
+.TP
 .B \-c
 Compile only. Suppress the linking phase of the
 compilation. Source code files are turned into compiled files, but no
@@ -318,9 +335,9 @@ option is given, specify the name of plugin file produced.
 .TP
 .B \-output\-obj
 Cause the linker to produce a C object file instead of an executable
-file. This is useful to wrap Caml code as a C library,
-callable from any C program. The name of the output object file is
-camlprog.o by default; it can be set with the
+file. This is useful to wrap OCaml code as a C library,
+callable from any C program. The name of the output object file 
+must be set with the
 .B \-o
 option.
 This option can also be used to produce a compiled shared/dynamic
@@ -378,7 +395,7 @@ Multiple levels of packing can be achieved by combining
 with
 .BR \-for\-pack .
 See
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "Native-code compilation" for more details.
 .TP
 .BI \-pp \ command
@@ -403,6 +420,16 @@ only recursive types where the recursion goes through an object type
 are supported. Note that once you have created an interface using this
 flag, you must use it again for all dependencies.
 .TP
+.BI \-runtime\-variant \ suffix
+Add
+.I suffix
+to the name of the runtime library that will be used by the program.
+If OCaml was configured with option
+.BR \-with\-debug\-runtime ,
+then the
+.B d
+suffix is supported and gives a debug version of the runtime.
+.TP
 .B \-S
 Keep the assembly code produced during the compilation. The assembly
 code for the source file
@@ -417,21 +444,24 @@ the
 module. The name of the plugin must be
 set with the
 .B \-o
-option. A plugin can include a number of Caml
+option. A plugin can include a number of OCaml
 modules and libraries, and extra native objects (.o, .a files).
 Building native plugins is only supported for some
 operating system. Under some systems (currently,
-only Linux AMD 64), all the Caml code linked in a plugin must have
+only Linux AMD 64), all the OCaml code linked in a plugin must have
 been compiled without the
 .B \-nodynlink
 flag. Some constraints might also
 apply to the way the extra native objects have been compiled (under
 Linux AMD 64, they must contain only position-independent code).
 .TP
+.B \-strict\-sequence
+The left-hand part of a sequence must have type unit.
+.TP
 .B \-thread
 Compile or link multithreaded programs, in combination with the
 system threads library described in
-.IR "The Objective Caml user's manual" .
+.IR "The OCaml user's manual" .
 .TP
 .B \-unsafe
 Turn bound checking off for array and string accesses (the
@@ -486,14 +516,14 @@ sign (or a lowercase letter) turns them back into warnings, and a
 .B @
 sign both enables and marks the corresponding warnings.
 
-Note: it is not recommended to use warning sets (i.e. letters) as
-arguments to
+Note: it is not recommended to use the
 .B \-warn\-error
-in production code, because this can break your build when future versions
-of OCaml add some new warnings.
+option in production code, because it will almost certainly prevent
+compiling your program with later versions of OCaml when they add new
+warnings.
 
 The default setting is
-.B \-warn\-error\ +a
+.B \-warn\-error\ -a
 (none of the warnings is treated as an error).
 .TP
 .B \-where
@@ -559,5 +589,5 @@ SPARC processors.
 .SH SEE ALSO
 .BR ocamlc (1).
 .br
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "Native-code compilation".

diff --git a/man/ocamlprof.m b/man/ocamlprof.m
index f92ab8e4424447a69df553f9e159e4918588f8cb..3f20398f0e6c54eac72ddb194140a992b9d637e5 100644 (file)
--- a/man/ocamlprof.m
+++ b/man/ocamlprof.m
@@ -1,8 +1,21 @@
-\" $Id$
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLPROF 1
 
 .SH NAME
-ocamlprof \- The Objective Caml profiler
+ocamlprof \- The OCaml profiler
 
 .SH SYNOPSIS
 .B ocamlprof
@@ -15,7 +28,7 @@ ocamlprof \- The Objective Caml profiler
 The
 .B ocamlprof
 command prints execution counts gathered during the execution of a
-Objective Caml program instrumented with
+OCaml program instrumented with
 .BR ocamlcp (1).
 
 It produces a source listing of the program modules given as arguments
@@ -69,5 +82,5 @@ Display a short usage summary and exit.
 .SH SEE ALSO
 .BR ocamlcp (1).
 .br
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "Profiling".

diff --git a/man/ocamlrun.m b/man/ocamlrun.m
index d7e7f037f5885d4fa083a489ff9aadaa1e12eae8..7aef64eebe394ff76323d941f26e0a30b1acee30 100644 (file)
--- a/man/ocamlrun.m
+++ b/man/ocamlrun.m
@@ -1,9 +1,21 @@
-\" $Id$
-
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLRUN 1
 
 .SH NAME
-ocamlrun \- The Objective Caml bytecode interpreter
+ocamlrun \- The OCaml bytecode interpreter
 
 .SH SYNOPSIS
 .B ocamlrun
@@ -23,7 +35,7 @@ command.
 The first non-option argument is taken to be the name of the file
 containing the executable bytecode. (That file is searched in the
 executable path as well as in the current directory.) The remaining
-arguments are passed to the Objective Caml program, in the string array
+arguments are passed to the OCaml program, in the string array
 .BR Sys.argv .
 Element 0 of this array is the name of the
 bytecode executable file; elements 1 to
@@ -60,6 +72,7 @@ flag in the OCAMLRUNPARAM environment variable (see below).
 Search the directory
 .I dir
 for dynamically-loaded libraries, in addition to the standard search path.
+.TP
 .B \-p
 Print the names of the primitives known to this version of
 .BR ocamlrun (1)
@@ -85,14 +98,14 @@ The following environment variable are also consulted:
 Additional directories to search for dynamically-loaded libraries.
 .TP
 .B OCAMLLIB
-The directory containing the Objective Caml standard
+The directory containing the OCaml standard
 library.  (If
 .B OCAMLLIB
 is not set,
 .B CAMLLIB
 will be used instead.) Used to locate the ld.conf configuration file for
 dynamic loading.  If not set,
-default to the library directory specified when compiling Objective Caml.
+default to the library directory specified when compiling OCaml.
 .TP
 .B OCAMLRUNPARAM
 Set the runtime system options and garbage collection parameters.
@@ -105,7 +118,7 @@ and an optional multiplier.  There are nine options, six of which
 correspond to the fields of the
 .B control
 record documented in
-.IR "The Objective Caml user's manual",
+.IR "The OCaml user's manual",
 chapter "Standard Library", section "Gc".
 .TP
 .B b
@@ -199,5 +212,5 @@ List of directories searched to find the bytecode executable file.
 .SH SEE ALSO
 .BR ocamlc (1).
 .br
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "Runtime system".

diff --git a/man/ocamlyacc.m b/man/ocamlyacc.m
index 232b17273b687c9222b2570593df209546fbc413..ce53cc4afae50381722dd6bd99df156023cd5501 100644 (file)
--- a/man/ocamlyacc.m
+++ b/man/ocamlyacc.m
@@ -1,8 +1,21 @@
-\" $Id$
+.\"***********************************************************************
+.\"*                                                                     *
+.\"*                                OCaml                                *
+.\"*                                                                     *
+.\"*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
+.\"*                                                                     *
+.\"*  Copyright 1996 Institut National de Recherche en Informatique et   *
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *
+.\"*  under the terms of the Q Public License version 1.0.               *
+.\"*                                                                     *
+.\"***********************************************************************
+.\"
+.\" $Id$
+.\"
 .TH OCAMLYACC 1
 
 .SH NAME
-ocamlyacc \- The Objective Caml parser generator
+ocamlyacc \- The OCaml parser generator
 
 .SH SYNOPSIS
 .B ocamlyacc
@@ -30,7 +43,7 @@ Assuming the input file is
 .IR grammar \&.mly,
 running
 .B ocamlyacc
-produces Caml code for a parser in the file
+produces OCaml code for a parser in the file
 .IR grammar \&.ml,
 and its interface in file
 .IR grammar \&.mli.
@@ -91,5 +104,5 @@ command line.
 .SH SEE ALSO
 .BR ocamllex (1).
 .br
-.IR "The Objective Caml user's manual" ,
+.IR "The OCaml user's manual" ,
 chapter "Lexer and parser generators".

diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 663847b4927cfce6a7bb4b7b0d6b810a2eee0e99..a95db6f3ab156604733ec8da1034aa56dfd1a826 100644 (file)
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -289,7 +289,7 @@ Pathname.define_context "ocamlbuild" ["ocamlbuild"; "stdlib"; "."];;
 Pathname.define_context "lex" ["lex"; "stdlib"];;
 
 List.iter (fun x -> let x = "otherlibs"/x in Pathname.define_context x [x; "stdlib"])
-  ["bigarray"; "dbm"; "graph"; "num"; "str"; "systhreads"; "unix"; "win32graph"; "win32unix"];;
+  ["bigarray"; "graph"; "num"; "str"; "systhreads"; "unix"; "win32graph"; "win32unix"];;
 
 (* The bootstrap standard library *)
 copy_rule "The bootstrap standard library" "stdlib/%" "boot/%";;
@@ -407,8 +407,6 @@ flag ["c"; "compile"; "otherlibs_bigarray"] (S[A"-I"; P"../otherlibs/bigarray"])
 flag [(* "ocaml" or "c"; *) "ocamlmklib"; "otherlibs_graph"] (S[Sh C.x11_link]);;
 flag ["c"; "compile"; "otherlibs_graph"] (S[Sh C.x11_includes; A"-I../otherlibs/graph"]);;
 flag ["c"; "compile"; "otherlibs_win32graph"] (A"-I../otherlibs/win32graph");;
-flag ["c"; "compile"; "otherlibs_dbm"] (Sh C.dbm_includes);;
-flag [(* "ocaml" oc "c"; *) "ocamlmklib"; "otherlibs_dbm"] (S[A"-oc"; A"otherlibs/dbm/mldbm"; Sh C.dbm_link]);;
 flag ["ocaml"; "ocamlmklib"; "otherlibs_threads"] (S[A"-oc"; A"otherlibs/threads/vmthreads"]);;
 flag ["c"; "compile"; "otherlibs_num"] begin
   S[A("-DBNG_ARCH_"^C.bng_arch);
@@ -676,7 +674,6 @@ let special_modules =
 let camlp4_import_list =
     ["utils/misc.ml";
      "utils/terminfo.ml";
-     "parsing/linenum.ml";
      "utils/warnings.ml";
      "parsing/location.ml";
      "parsing/longident.ml";
@@ -1049,7 +1046,7 @@ rule "labltk"
   ~prod:"otherlibs/labltk/lib/labltk"
   begin fun _ _ ->
     Echo(["#!/bin/sh\n";
-          Printf.sprintf "exec %s -I %s $*\n" (labltk_installdir/"labltktop") labltk_installdir],
+          Printf.sprintf "exec %s -I %s \"$@\"\n" (labltk_installdir/"labltktop") labltk_installdir],
          "otherlibs/labltk/lib/labltk")
   end;;
 

diff --git a/myocamlbuild_config.mli b/myocamlbuild_config.mli
index 28b2261776b938bb9a42ce2797a2fff18d596a0b..5eec980326057566570f527b6fe429944fad59cf 100644 (file)
--- a/myocamlbuild_config.mli
+++ b/myocamlbuild_config.mli
@@ -1,9 +1,22 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                 OCaml                                 *)
+(*                                                                       *)
+(*         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                       *)
+(*   Copyright 2007 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
+
 val prefix : string
 val bindir : string
 val libdir : string
 val manext : string
 val ranlib : string
 val ranlibcmd : string
+val arcmd : string
 val sharpbangscripts : bool
 val bng_arch : string
 val bng_asm_level : string
@@ -11,8 +24,6 @@ val pthread_link : string
 val x11_includes : string
 val x11_link : string
 val tk_link : string
-val dbm_includes : string
-val dbm_link : string
 val bytecc : string
 val bytecccompopts : string
 val bytecclinkopts : string

diff --git a/ocamlbuild/ChangeLog b/ocamlbuild/ChangeLog
index a844e38b8507cdaaaf4e8562476ad7f56f477fcd..0899500eb36217bf791c2f246a0001568b97cd1a 100644 (file)
--- a/ocamlbuild/ChangeLog
+++ b/ocamlbuild/ChangeLog
@@ -2302,7 +2302,7 @@
 
 2006-12-08  Nicolas Pouillard  <nicolas.pouillard@gmail.com>
 
-       Ocaml distrib stuffs.
+       OCaml distrib stuffs.
 
        * command.ml,
        * command.mli: Add a normalization callback.

diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile
index 0f1903369773f49e631408a415d1391bae3bfe17..e4ee877eb4469e8e8891382811e704bdb5e5b735 100644 (file)
--- a/ocamlbuild/Makefile
+++ b/ocamlbuild/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #   Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt  #
 #                                                                       #

diff --git a/ocamlbuild/_tags b/ocamlbuild/_tags
index 617d6a72f385e5b09678ace29e2255e32a83c6b0..cf63d89276aad5280a535e38af53cdea827e25f9 100644 (file)
--- a/ocamlbuild/_tags
+++ b/ocamlbuild/_tags
@@ -1,10 +1,22 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#         Nicolas Pouillard, projet Gallium, INRIA Rocquencourt         #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # OCamlbuild tags file
 true: debug
 <*.ml> or <*.mli>: warn_L, warn_R, warn_Z, annot
 "discard_printf.ml": rectypes
 "ocamlbuildlib.cma" or "ocamlbuildlightlib.cma": linkall
 <*.byte> or <*.native> or <*.top>: use_unix
-"ocamlbuildlight.byte": -use_unix
+"ocamlbuildlight.byte": -use_unix, nopervasives
 <*.cmx>: for-pack(Ocamlbuild_pack)
 <{ocamlbuild_{pack,unix_plugin,plugin,executor},ppcache}{,.p}.cmx>: -for-pack(Ocamlbuild_pack)
 "doc": not_hygienic

diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml
index 131cd8586c71300b8deaf7ded6674593079500c2..1ce80c974351136492d2311c9f441b4c96172674 100644 (file)
--- a/ocamlbuild/command.ml
+++ b/ocamlbuild/command.ml
@@ -91,9 +91,15 @@ let atomize_paths l = S(List.map (fun x -> P x) l)
 
 let env_path = lazy begin
   let path_var = Sys.getenv "PATH" in
+  let parse_path =
+    if Sys.os_type = "Win32" then
+      Lexers.parse_environment_path_w
+    else
+      Lexers.parse_environment_path
+  in
   let paths =
     try
-      Lexers.parse_environment_path (Lexing.from_string path_var)
+      parse_path (Lexing.from_string path_var)
     with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg))
   in
   let norm_current_dir_name path =
@@ -119,21 +125,33 @@ let virtual_solver virtual_command =
     failwith (Printf.sprintf "the solver for the virtual command %S \
                               has failed finding a valid command" virtual_command)
 
+(* On Windows, we need to also check for the ".exe" version of the file. *)
+let file_or_exe_exists file =
+  sys_file_exists file || Sys.os_type = "Win32" && sys_file_exists (file ^ ".exe")
 
-(* FIXME windows *)
 let search_in_path cmd =
+  (* Try to find [cmd] in path [path]. *)
+  let try_path path =
+    (* Don't know why we're trying to be subtle here... *)
+    if path = Filename.current_dir_name then file_or_exe_exists cmd
+    else file_or_exe_exists (filename_concat path cmd)
+  in
   if Filename.is_implicit cmd then
-    let path = List.find begin fun path ->
-      if path = Filename.current_dir_name then sys_file_exists cmd
-      else sys_file_exists (filename_concat path cmd)
-    end !*env_path in
+    let path = List.find try_path !*env_path in
+    (* We're not trying to append ".exe" here because all windows shells are
+     * capable of understanding the command without the ".exe" suffix. *)
     filename_concat path cmd
-  else cmd
+  else
+    cmd
 
 (*** string_of_command_spec{,_with_calls *)
 let rec string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals spec =
   let self = string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals in
   let b = Buffer.create 256 in
+  (* The best way to prevent bash from switching to its windows-style
+   * quote-handling is to prepend an empty string before the command name. *)
+  if Sys.os_type = "Win32" then
+    Buffer.add_string b "''";
   let first = ref true in
   let put_space () =
     if !first then

diff --git a/ocamlbuild/command.mli b/ocamlbuild/command.mli
index 0cdc602c8a89566d05b7bad9941192b0f7b22fc4..f54b8e8ac1d7459c2c88c6ddfe3694f3893f3f98 100644 (file)
--- a/ocamlbuild/command.mli
+++ b/ocamlbuild/command.mli
@@ -44,3 +44,5 @@ val deps_of_tags : Tags.t -> pathname list
 val dep : Tags.elt list -> pathname list -> unit
 
 val pdep : Tags.elt list -> Tags.elt -> (string -> pathname list) -> unit
+
+val file_or_exe_exists: string -> bool

diff --git a/ocamlbuild/digest_cache.ml b/ocamlbuild/digest_cache.ml
index 95ddfed1c83dd680b3cc6ff8dd76d49991cd505a..5f624afcc4a94213406f99c41cd2c968a2bcd63a 100644 (file)
--- a/ocamlbuild/digest_cache.ml
+++ b/ocamlbuild/digest_cache.ml
@@ -20,7 +20,7 @@ let get = Hashtbl.find digests
 
 let put = Hashtbl.replace digests
 
-let _digests = lazy (Pathname.pwd / !Options.build_dir / (Pathname.mk "_digests"))
+let _digests = lazy (!Options.build_dir / (Pathname.mk "_digests"))
 
 let finalize () =
   with_output_file !*_digests begin fun oc ->

diff --git a/ocamlbuild/exit_codes.ml b/ocamlbuild/exit_codes.ml
index 19cb4f02fc704ea513b518d1a820e45e20eb480d..71c9f06f26d138ddb0017ca8f08cb37457684f48 100644 (file)
--- a/ocamlbuild/exit_codes.ml
+++ b/ocamlbuild/exit_codes.ml
@@ -1,3 +1,14 @@
+(***********************************************************************)
+(*                             ocamlbuild                              *)
+(*                                                                     *)
+(*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let rc_ok                              = 0
 let rc_usage                           = 1
 let rc_failure                         = 2

diff --git a/ocamlbuild/exit_codes.mli b/ocamlbuild/exit_codes.mli
index acbc0ede3c15a792b459f2079df8ab8ed8d2b83e..a83a300b608ddb066fc2cc3db114278112e00421 100644 (file)
--- a/ocamlbuild/exit_codes.mli
+++ b/ocamlbuild/exit_codes.mli
@@ -1,3 +1,14 @@
+(***********************************************************************)
+(*                             ocamlbuild                              *)
+(*                                                                     *)
+(*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 val rc_ok                              : int
 val rc_usage                           : int
 val rc_failure                         : int

diff --git a/ocamlbuild/fda.ml b/ocamlbuild/fda.ml
index 4d4bbac0277e077bc89b4519df21fcf7bc428c79..d359f7819412c14dcb42bc57f21989c89386a2b8 100644 (file)
--- a/ocamlbuild/fda.ml
+++ b/ocamlbuild/fda.ml
@@ -22,10 +22,10 @@ exception Exit_hygiene_failed
 
 let laws =
   [
-    { law_name = "Leftover Ocaml compilation files";
+    { law_name = "Leftover OCaml compilation files";
       law_rules = [Not ".cmo"; Not ".cmi"; Not ".cmx"; Not ".cma"; Not ".cmxa"];
       law_penalty = Fail };
-    { law_name = "Leftover Ocaml type annotation files";
+    { law_name = "Leftover OCaml type annotation files";
       law_rules = [Not ".annot"];
       law_penalty = Warn };
     { law_name = "Leftover object files";

diff --git a/ocamlbuild/hygiene.ml b/ocamlbuild/hygiene.ml
index e904afb44d32d2f944c0711275aaa274f553a57a..97a9ea927580a546880e7e6703856e91afb4810e 100644 (file)
--- a/ocamlbuild/hygiene.ml
+++ b/ocamlbuild/hygiene.ml
@@ -150,7 +150,9 @@ let check ?sanitize laws entry =
                @ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions\
                @ or@ using@ the@ -no-hygiene@ option).@]"
                m (if m = 1 then "" else "s") fn;
-            let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o755 fn in
+            let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o755 fn in
+            (* See PR #5338: under mingw, one produces a shell script, which must follow
+               Unix eol convention; hence Open_binary. *)
             let fp = Printf.fprintf in
             fp oc "#!/bin/sh\n\
                    # File generated by ocamlbuild\n\

diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli
index 2f37edca64f3dcdc82438d92782392e46e809aea..bc5de4cfb187a0f500ad756ba5e3fc80340ddd22 100644 (file)
--- a/ocamlbuild/lexers.mli
+++ b/ocamlbuild/lexers.mli
@@ -32,6 +32,8 @@ val trim_blanks : Lexing.lexbuf -> string
    Example:
       ":aaa:bbb:::ccc:" -> [""; "aaa"; "bbb"; ""; ""; "ccc"; ""] *)
 val parse_environment_path : Lexing.lexbuf -> string list
+(* Same one, for Windows (PATH is ;-separated) *)
+val parse_environment_path_w : Lexing.lexbuf -> string list
 
 val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf
 val path_scheme : bool -> Lexing.lexbuf ->

diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll
index 7b191b0d978e3655d66fe91e5928d975638d898b..2206f862c05eb43521d21bec8e403118beb696c1 100644 (file)
--- a/ocamlbuild/lexers.mll
+++ b/ocamlbuild/lexers.mll
@@ -81,6 +81,15 @@ and comma_or_blank_sep_strings_aux = parse
   | space* eof { [] }
   | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") }
 
+and parse_environment_path_w = parse
+  | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf }
+  | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w lexbuf }
+  | eof { [] }
+and parse_environment_path_aux_w = parse
+  | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf }
+  | eof { [] }
+  | _ { raise (Error "Impossible: expecting colon-separated strings") }
+
 and parse_environment_path = parse
   | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf }
   | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux lexbuf }

diff --git a/ocamlbuild/man/ocamlbuild.1 b/ocamlbuild/man/ocamlbuild.1
index 58a33740b7c5f1bcfad065fc103527dbccd4386c..918c5981021e62eff37925be462eb24acc2a4a86 100644 (file)
--- a/ocamlbuild/man/ocamlbuild.1
+++ b/ocamlbuild/man/ocamlbuild.1
@@ -1,7 +1,18 @@
+.\"***********************************************************************)
+.\"*                             ocamlbuild                              *)
+.\"*                                                                     *)
+.\"*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+.\"*                                                                     *)
+.\"*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+.\"*  en Automatique.  All rights reserved.  This file is distributed    *)
+.\"*  under the terms of the Q Public License version 1.0.               *)
+.\"*                                                                     *)
+.\"***********************************************************************)
+.\"
 .TH OCAMLBUILD 1
 
 .SH NAME
-ocamlbuild \- The Objective Caml project compilation tool
+ocamlbuild \- The OCaml project compilation tool
 
 
 .SH SYNOPSIS
@@ -57,7 +68,7 @@ produce.  Target names are of the form
 .BR base.extension
 where
 .BR base
-is usually the name of the underlying Ocaml module and
+is usually the name of the underlying OCaml module and
 .BR extension
 denotes the kind of object to produce from that file -- a byte code executable,
 a native executable, documentation...
@@ -250,4 +261,4 @@ manual,
 .BR ocaml (1),
 .BR make (1).
 .br
-.I The Objective Caml user's manual, chapter "Batch compilation".
+.I The OCaml user's manual, chapter "Batch compilation".

diff --git a/ocamlbuild/manual/.cvsignore b/ocamlbuild/manual/.cvsignore
deleted file mode 100644 (file)
index a7bf093..0000000
--- a/ocamlbuild/manual/.cvsignore
+++ /dev/null
@@ -1,6 +0,0 @@
-*.aux
-*.haux
-*.html
-*.htoc
-*.log
-*.pdf

diff --git a/ocamlbuild/manual/.ignore b/ocamlbuild/manual/.ignore
new file mode 100644 (file)
index 0000000..a7bf093
--- /dev/null
+++ b/ocamlbuild/manual/.ignore
@@ -0,0 +1,6 @@
+*.aux
+*.haux
+*.html
+*.htoc
+*.log
+*.pdf

diff --git a/ocamlbuild/manual/Makefile b/ocamlbuild/manual/Makefile
index 055d42e71fbbbfa57f35e56c3860012f149d25b7..595f730eede8cc377ea2a0a4313845c592154e05 100644 (file)
--- a/ocamlbuild/manual/Makefile
+++ b/ocamlbuild/manual/Makefile
@@ -1,3 +1,14 @@
+#######################################################################
+#                             ocamlbuild                              #
+#                                                                     #
+#  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt #
+#                                                                     #
+#  Copyright 2007 Institut National de Recherche en Informatique et   #
+#  en Automatique.  All rights reserved.  This file is distributed    #
+#  under the terms of the Q Public License version 1.0.               #
+#                                                                     #
+#######################################################################
+
 # Makefile
 
 all: manual.pdf manual.html

diff --git a/ocamlbuild/manual/manual.tex b/ocamlbuild/manual/manual.tex
index 62d900450f4b670d887ef76f26dec294fd9a6bcb..bccdd9a6fe26b64b9caee0cfc7f8148b8daafd24 100644 (file)
--- a/ocamlbuild/manual/manual.tex
+++ b/ocamlbuild/manual/manual.tex
@@ -1,4 +1,15 @@
 %                                                                -*- LaTeX -*-
+%(***********************************************************************)
+%(*                             ocamlbuild                              *)
+%(*                                                                     *)
+%(*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+%(*                                                                     *)
+%(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+%(*  en Automatique.  All rights reserved.  This file is distributed    *)
+%(*  under the terms of the Q Public License version 1.0.               *)
+%(*                                                                     *)
+%(***********************************************************************)
+
 %(*** preamble
 \documentclass[9pt]{article}
 \usepackage[utf8]{inputenc}
@@ -609,7 +620,7 @@ library.   Just   write   a   file  with  the  \texttt{mltop}  extension  (like
 \subsection{Preprocessor options and tags}
 You can specify preprocessor options with \texttt{-pp} followed by the
 preprocessor string, for instance \texttt{ocamlbuild -pp "camlp4o.opt -unsafe"}
-would run your sources thru CamlP4 with the \texttt{-unsafe} option.
+would run your sources through CamlP4 with the \texttt{-unsafe} option.
 Another way is to use the tags file.
 \begin{center}
   \begin{tabular}{|l|l|l|}

diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml
index 78286b53c8966732ae2781f5347443061ab862e5..3ba8550242ee5e38ab1d3f2eab313080d1c7d56f 100644 (file)
--- a/ocamlbuild/my_std.ml
+++ b/ocamlbuild/my_std.ml
@@ -249,18 +249,17 @@ let sys_command =
   | "Win32" -> fun cmd ->
       if cmd = "" then 0 else
       let cmd = "bash -c "^Filename.quote cmd in
-      (* FIXME fix Filename.quote for windows *)
-      let cmd = String.subst "\"&\"\"&\"" "&&" cmd in
       Sys.command cmd
   | _ -> fun cmd -> if cmd = "" then 0 else Sys.command cmd
 
 (* FIXME warning fix and use Filename.concat *)
 let filename_concat x y =
   if x = Filename.current_dir_name || x = "" then y else
-  if x.[String.length x - 1] = '/' then
+  if Sys.os_type = "Win32" && (x.[String.length x - 1] = '\\') || x.[String.length x - 1] = '/' then
     if y = "" then x
     else x ^ y
-  else x ^ "/" ^ y
+  else
+    x ^ "/" ^ y
 
 (* let reslash =
   match Sys.os_type with

diff --git a/ocamlbuild/ocaml_dependencies.mli b/ocamlbuild/ocaml_dependencies.mli
index 68bc427cc2b450f4aee8a3836a4673241e4cda1d..5c1ebfe66cec9638d15056f70a727af4c635f321 100644 (file)
--- a/ocamlbuild/ocaml_dependencies.mli
+++ b/ocamlbuild/ocaml_dependencies.mli
@@ -11,7 +11,7 @@
 
 
 (* Original author: Nicolas Pouillard *)
-(** Ocaml dependencies *)
+(** OCaml dependencies *)
 
 exception Circular_dependencies of string list * string
 

diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml
index 1b830addbf68922cf42bb1a15c34abceda53a4d4..79c149371b4734571e7716b2d8d1d4623d618ccc 100644 (file)
--- a/ocamlbuild/ocaml_specific.ml
+++ b/ocamlbuild/ocaml_specific.ml
@@ -434,7 +434,7 @@ let () =
     (* tags package(X), predicate(X) and syntax(X) *)
     List.iter begin fun tags ->
       pflag tags "package" (fun pkg -> S [A "-package"; A pkg]);
-      pflag tags "predicate" (fun pkg -> S [A "-predicate"; A pkg]);
+      pflag tags "predicate" (fun pkg -> S [A "-predicates"; A pkg]);
       pflag tags "syntax" (fun pkg -> S [A "-syntax"; A pkg])
     end all_tags
   end else begin
@@ -527,7 +527,9 @@ flag ["ocaml"; "compile"; "thread"] (A "-thread");;
 if not !Options.use_ocamlfind then begin
   flag ["ocaml"; "doc"; "thread"] (S[A"-I"; A"+threads"]);
   flag ["ocaml"; "link"; "thread"; "native"; "program"] (S[A "threads.cmxa"; A "-thread"]);
-  flag ["ocaml"; "link"; "thread"; "byte"; "program"] (S[A "threads.cma"; A "-thread"])
+  flag ["ocaml"; "link"; "thread"; "byte"; "program"] (S[A "threads.cma"; A "-thread"]);
+  flag ["ocaml"; "link"; "thread"; "native"; "toplevel"] (S[A "threads.cmxa"; A "-thread"]);
+  flag ["ocaml"; "link"; "thread"; "byte"; "toplevel"] (S[A "threads.cma"; A "-thread"])
 end else begin
   flag ["ocaml"; "link"; "thread"; "program"] (A "-thread")
 end;;

diff --git a/ocamlbuild/ocaml_tools.ml b/ocamlbuild/ocaml_tools.ml
index 1381ca465a39a370f0cc48e154641c3d3f658c9c..f68aff42ad11f23d818f8e5305e6951636a1ab5a 100644 (file)
--- a/ocamlbuild/ocaml_tools.ml
+++ b/ocamlbuild/ocaml_tools.ml
@@ -93,6 +93,7 @@ let infer_interface ml mli env build =
   let tags = tags_of_pathname ml++"ocaml" in
   Ocaml_compiler.prepare_compile build ml;
   Cmd(S[!Options.ocamlc; ocaml_ppflags tags; ocaml_include_flags ml; A"-i";
+        (if Tags.mem "thread" tags then A"-thread" else N);
         T(tags++"infer_interface"); P ml; Sh">"; Px mli])
 
 let menhir mly env build =

diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml
index 3dafe25a415f45c56d79a5958f5af8d5c34f294d..7726825c19778f6496dc0b695869cc626698a687 100644 (file)
--- a/ocamlbuild/ocaml_utils.ml
+++ b/ocamlbuild/ocaml_utils.ml
@@ -29,8 +29,7 @@ let flag_and_dep tags cmd_spec =
   dep tags ps
 
 let stdlib_dir = lazy begin
-  (* FIXME *)
-  let ocamlc_where = sprintf "%s/ocamlc.where" (Pathname.pwd / !Options.build_dir) in
+  let ocamlc_where = !Options.build_dir / (Pathname.mk "ocamlc.where") in
   let () = Command.execute ~quiet:true (Cmd(S[!Options.ocamlc; A"-where"; Sh">"; P ocamlc_where])) in
   String.chomp (read_file ocamlc_where)
 end

diff --git a/ocamlbuild/ocamlbuild-presentation.rslide b/ocamlbuild/ocamlbuild-presentation.rslide
index 30ba657b35c429a5c440b4e75ae02e875aaca86c..bb32c4777c85a1abf93f81fb7cea81ebfc996c64 100644 (file)
--- a/ocamlbuild/ocamlbuild-presentation.rslide
+++ b/ocamlbuild/ocamlbuild-presentation.rslide
@@ -1,3 +1,15 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#   Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt  #
+#                                                                       #
+#   Copyright 2007 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
 # Works with rslide revision 8
 # http://gallium.inria.fr/~pouillar/rslide/rslide
 documentclass :beamer, :t, :compress, :red
@@ -109,7 +121,7 @@ slide "How difficult is it to build regular projects by hand?" do
 end
 
 slide "How does ocamlbuild manage all that?" do
-  > It has a lot of hand-crafted Ocaml-specific compilation logic!
+  > It has a lot of hand-crafted OCaml-specific compilation logic!
   box "A dynamic exploration approach", '<2>' do
     * Start from the given targets
     * Attempt to discover dependencies using _ocamldep_

diff --git a/ocamlbuild/ocamlbuild_plugin.mli b/ocamlbuild/ocamlbuild_plugin.mli
index 8e642f31a265e60b4e1d84cf9641a034b29e4e19..0844b4d7ca7db8bb74c7be483bbffb659c63974c 100644 (file)
--- a/ocamlbuild/ocamlbuild_plugin.mli
+++ b/ocamlbuild/ocamlbuild_plugin.mli
@@ -1,3 +1,14 @@
+(***********************************************************************)
+(*                             ocamlbuild                              *)
+(*                                                                     *)
+(*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 include Ocamlbuild_pack.Signatures.PLUGIN
   with module Pathname = Ocamlbuild_pack.Pathname
    and module Outcome  = Ocamlbuild_pack.My_std.Outcome

diff --git a/ocamlbuild/ocamlbuild_where.ml b/ocamlbuild/ocamlbuild_where.ml
index 14fcde5d725c6de448249560b44ac718fa13b59b..d65b41edcaf8e6da15a9ef1206e6609a70b91c51 100644 (file)
--- a/ocamlbuild/ocamlbuild_where.ml
+++ b/ocamlbuild/ocamlbuild_where.ml
@@ -1,3 +1,14 @@
+(***********************************************************************)
+(*                             ocamlbuild                              *)
+(*                                                                     *)
+(*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
+(*                                                                     *)
+(*  Copyright 2007 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
 let bindir = ref Ocamlbuild_Myocamlbuild_config.bindir;;
 let libdir = ref begin
   Filename.concat

diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml
index e547d44e3e6e53277ce29eaad07fbd1970fa5cb2..d17e0dc13649b5a12fcd95e2a00b61b6c35b4dab 100644 (file)
--- a/ocamlbuild/options.ml
+++ b/ocamlbuild/options.ml
@@ -22,7 +22,7 @@ open Format
 open Command
 
 let entry = ref None
-let build_dir = ref "_build"
+let build_dir = ref (Filename.concat (Sys.getcwd ()) "_build")
 let include_dirs = ref []
 let exclude_dirs = ref []
 let nothing_should_be_rebuilt = ref false
@@ -50,8 +50,8 @@ let mk_virtual_solvers =
       if sys_file_exists !dir then
         let long = filename_concat !dir cmd in
         let long_opt = long ^ ".opt" in
-        if sys_file_exists long_opt then A long_opt
-        else if sys_file_exists long then A long
+        if file_or_exe_exists long_opt then A long_opt
+        else if file_or_exe_exists long then A long
         else try let _ = search_in_path opt in a_opt
         with Not_found -> a_cmd
       else
@@ -126,7 +126,12 @@ let add_to' rxs x =
   else
     ()
 let set_cmd rcmd = String (fun s -> rcmd := Sh s)
-let set_build_dir s = make_links := false; build_dir := s
+let set_build_dir s =
+  make_links := false;
+  if Filename.is_relative s then
+    build_dir := Filename.concat (Sys.getcwd ()) s
+  else
+    build_dir := s
 let spec = ref (
   Arg.align
   [

diff --git a/ocamlbuild/shell.ml b/ocamlbuild/shell.ml
index c76d154583889aae81e1f1deb2b1f278d4ad6004..3fbeb81aa7495708f5c311b778c89d53f6b6a28c 100644 (file)
--- a/ocamlbuild/shell.ml
+++ b/ocamlbuild/shell.ml
@@ -23,7 +23,12 @@ let is_simple_filename s =
     | _ -> false in
   loop 0
 let quote_filename_if_needed s =
-  if is_simple_filename s then s else Filename.quote s
+  if is_simple_filename s then s
+  (* We should probably be using [Filename.unix_quote] except that function
+   * isn't exported. Users on Windows will have to live with not being able to
+   * install OCaml into c:\o'caml. Too bad. *)
+  else if Sys.os_type = "Win32" then Printf.sprintf "'%s'" s
+  else Filename.quote s
 let chdir dir =
   reset_filesys_cache ();
   Sys.chdir dir

diff --git a/ocamlbuild/shell.mli b/ocamlbuild/shell.mli
index d393c7b3e77c14baa367806010ca51ee8c7ae79a..2d867b032da1373117b896566198493c5a12f47c 100644 (file)
--- a/ocamlbuild/shell.mli
+++ b/ocamlbuild/shell.mli
@@ -9,10 +9,14 @@
 (*                                                                     *)
 (***********************************************************************)
 
-
 (* Original author: Nicolas Pouillard *)
+
 val is_simple_filename : string -> bool
+
 val quote_filename_if_needed : string -> string
+(** This will quote using Unix conventions, even on Windows, because commands are
+ * always run through bash -c on Windows. *)
+
 val chdir : string -> unit
 val rm : string -> unit
 val rm_f : string -> unit

diff --git a/ocamlbuild/start.sh b/ocamlbuild/start.sh
index 20b7b765618a2cdc2bbdfa91fb509dd3366eb89f..7386cbd3eb824fa85484be9731c22d8be8093862 100755 (executable)
--- a/ocamlbuild/start.sh
+++ b/ocamlbuild/start.sh
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #       Nicolas Pouillard, projet Gallium, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/ocamldoc/.cvsignore b/ocamldoc/.cvsignore
deleted file mode 100644 (file)
index 0372a09..0000000
--- a/ocamldoc/.cvsignore
+++ /dev/null
@@ -1,17 +0,0 @@
-ocamldoc
-ocamldoc.opt
-odoc_crc.ml
-odoc_lexer.ml
-odoc_ocamlhtml.ml
-odoc_parser.ml
-odoc_parser.mli
-odoc_see_lexer.ml
-odoc_text_lexer.ml
-odoc_text_parser.ml
-odoc_text_parser.mli
-stdlib_man
-*.output
-test_stdlib
-test_latex
-test
-*.a

diff --git a/ocamldoc/.depend b/ocamldoc/.depend
index 355a0a2fc3f3896c981a2bcc341569ed5d2818a4..09162d0f970f61475d62f646e57a266103d6a16b 100644 (file)
--- a/ocamldoc/.depend
+++ b/ocamldoc/.depend
@@ -1,12 +1,12 @@
-odoc.cmo: ../typing/typedtree.cmi odoc_texi.cmo odoc_messages.cmo \
-    odoc_man.cmo odoc_latex.cmo odoc_info.cmi odoc_html.cmo odoc_global.cmi \
-    odoc_dot.cmo odoc_config.cmi odoc_args.cmi odoc_analyse.cmi \
-    ../utils/misc.cmi ../utils/config.cmi ../utils/clflags.cmi
-odoc.cmx: ../typing/typedtree.cmx odoc_texi.cmx odoc_messages.cmx \
-    odoc_man.cmx odoc_latex.cmx odoc_info.cmx odoc_html.cmx odoc_global.cmx \
-    odoc_dot.cmx odoc_config.cmx odoc_args.cmx odoc_analyse.cmx \
-    ../utils/misc.cmx ../utils/config.cmx ../utils/clflags.cmx
-odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \
+odoc.cmo : ../typing/typedtree.cmi odoc_messages.cmo odoc_info.cmi \
+    odoc_global.cmi odoc_gen.cmi odoc_config.cmi odoc_args.cmi \
+    odoc_analyse.cmi ../utils/misc.cmi ../utils/config.cmi \
+    ../utils/clflags.cmi
+odoc.cmx : ../typing/typedtree.cmx odoc_messages.cmx odoc_info.cmx \
+    odoc_global.cmx odoc_gen.cmx odoc_config.cmx odoc_args.cmx \
+    odoc_analyse.cmx ../utils/misc.cmx ../utils/config.cmx \
+    ../utils/clflags.cmx
+odoc_analyse.cmo : ../utils/warnings.cmi ../typing/typetexp.cmi \
     ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \
     ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \
     ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \
@@ -14,11 +14,11 @@ odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \
     odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \
     odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_dep.cmo \
     odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \
-    odoc_args.cmi ../utils/misc.cmi ../parsing/location.cmi \
-    ../parsing/lexer.cmi ../typing/includemod.cmi ../typing/env.cmi \
-    ../typing/ctype.cmi ../utils/config.cmi ../utils/clflags.cmi \
-    ../utils/ccomp.cmi odoc_analyse.cmi
-odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \
+    ../utils/misc.cmi ../parsing/location.cmi ../parsing/lexer.cmi \
+    ../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \
+    ../utils/config.cmi ../utils/clflags.cmi ../utils/ccomp.cmi \
+    odoc_analyse.cmi
+odoc_analyse.cmx : ../utils/warnings.cmx ../typing/typetexp.cmx \
     ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \
     ../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \
     ../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \
@@ -26,220 +26,231 @@ odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \
     odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \
     odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_dep.cmx \
     odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \
-    odoc_args.cmx ../utils/misc.cmx ../parsing/location.cmx \
-    ../parsing/lexer.cmx ../typing/includemod.cmx ../typing/env.cmx \
-    ../typing/ctype.cmx ../utils/config.cmx ../utils/clflags.cmx \
-    ../utils/ccomp.cmx odoc_analyse.cmi
-odoc_args.cmo: odoc_types.cmi odoc_module.cmo odoc_messages.cmo \
-    odoc_global.cmi odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi \
-    ../utils/clflags.cmi odoc_args.cmi
-odoc_args.cmx: odoc_types.cmx odoc_module.cmx odoc_messages.cmx \
-    odoc_global.cmx odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx \
-    ../utils/clflags.cmx odoc_args.cmi
-odoc_ast.cmo: ../typing/types.cmi ../typing/typedtree.cmi \
+    ../utils/misc.cmx ../parsing/location.cmx ../parsing/lexer.cmx \
+    ../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \
+    ../utils/config.cmx ../utils/clflags.cmx ../utils/ccomp.cmx \
+    odoc_analyse.cmi
+odoc_args.cmo : odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \
+    odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \
+    odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi
+odoc_args.cmx : odoc_types.cmx odoc_texi.cmx odoc_messages.cmx odoc_man.cmx \
+    odoc_latex.cmx odoc_html.cmx odoc_global.cmx odoc_gen.cmx odoc_dot.cmx \
+    odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx odoc_args.cmi
+odoc_ast.cmo : ../typing/types.cmi ../typing/typedtree.cmi \
     ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \
     odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \
     odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \
     odoc_global.cmi odoc_exception.cmo odoc_env.cmi odoc_class.cmo \
-    odoc_args.cmi ../utils/misc.cmi ../parsing/location.cmi \
-    ../typing/ident.cmi ../parsing/asttypes.cmi odoc_ast.cmi
-odoc_ast.cmx: ../typing/types.cmx ../typing/typedtree.cmx \
+    ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \
+    ../parsing/asttypes.cmi odoc_ast.cmi
+odoc_ast.cmx : ../typing/types.cmx ../typing/typedtree.cmx \
     ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \
     odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \
     odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \
     odoc_global.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \
-    odoc_args.cmx ../utils/misc.cmx ../parsing/location.cmx \
-    ../typing/ident.cmx ../parsing/asttypes.cmi odoc_ast.cmi
-odoc_class.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
+    ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \
+    ../parsing/asttypes.cmi odoc_ast.cmi
+odoc_class.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
     odoc_parameter.cmo odoc_name.cmi
-odoc_class.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \
+odoc_class.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \
     odoc_parameter.cmx odoc_name.cmx
-odoc_comments.cmo: odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \
+odoc_comments.cmo : odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \
     odoc_parser.cmi odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi \
     odoc_lexer.cmo odoc_global.cmi odoc_cross.cmi odoc_comments_global.cmi \
     odoc_comments.cmi
-odoc_comments.cmx: odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \
+odoc_comments.cmx : odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \
     odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx \
     odoc_lexer.cmx odoc_global.cmx odoc_cross.cmx odoc_comments_global.cmx \
     odoc_comments.cmi
-odoc_comments_global.cmo: odoc_comments_global.cmi
-odoc_comments_global.cmx: odoc_comments_global.cmi
-odoc_config.cmo: ../utils/config.cmi odoc_config.cmi
-odoc_config.cmx: ../utils/config.cmx odoc_config.cmi
-odoc_control.cmo:
-odoc_control.cmx:
-odoc_cross.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \
+odoc_comments_global.cmo : odoc_comments_global.cmi
+odoc_comments_global.cmx : odoc_comments_global.cmi
+odoc_config.cmo : ../utils/config.cmi odoc_config.cmi
+odoc_config.cmx : ../utils/config.cmx odoc_config.cmi
+odoc_control.cmo :
+odoc_control.cmx :
+odoc_cross.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \
     odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \
-    odoc_misc.cmi odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \
-    odoc_cross.cmi
-odoc_cross.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \
+    odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \
+    odoc_class.cmo odoc_cross.cmi
+odoc_cross.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_search.cmx \
     odoc_scan.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \
-    odoc_misc.cmx odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \
-    odoc_cross.cmi
-odoc_dag2html.cmo: odoc_info.cmi odoc_dag2html.cmi
-odoc_dag2html.cmx: odoc_info.cmx odoc_dag2html.cmi
-odoc_dep.cmo: ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \
+    odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \
+    odoc_class.cmx odoc_cross.cmi
+odoc_dag2html.cmo : odoc_info.cmi odoc_dag2html.cmi
+odoc_dag2html.cmx : odoc_info.cmx odoc_dag2html.cmi
+odoc_dep.cmo : ../parsing/parsetree.cmi odoc_type.cmo odoc_print.cmi \
     odoc_module.cmo ../tools/depend.cmi
-odoc_dep.cmx: ../parsing/parsetree.cmi odoc_type.cmx odoc_print.cmx \
+odoc_dep.cmx : ../parsing/parsetree.cmi odoc_type.cmx odoc_print.cmx \
     odoc_module.cmx ../tools/depend.cmx
-odoc_dot.cmo: odoc_info.cmi
-odoc_dot.cmx: odoc_info.cmx
-odoc_env.cmo: ../typing/types.cmi ../typing/printtyp.cmi ../typing/predef.cmi \
-    ../typing/path.cmi odoc_name.cmi ../typing/btype.cmi odoc_env.cmi
-odoc_env.cmx: ../typing/types.cmx ../typing/printtyp.cmx ../typing/predef.cmx \
-    ../typing/path.cmx odoc_name.cmx ../typing/btype.cmx odoc_env.cmi
-odoc_exception.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi
-odoc_exception.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx
-odoc_global.cmo: ../utils/clflags.cmi odoc_global.cmi
-odoc_global.cmx: ../utils/clflags.cmx odoc_global.cmi
-odoc_html.cmo: odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \
-    odoc_info.cmi odoc_dag2html.cmi odoc_args.cmi ../parsing/asttypes.cmi
-odoc_html.cmx: odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \
-    odoc_info.cmx odoc_dag2html.cmx odoc_args.cmx ../parsing/asttypes.cmi
-odoc_info.cmo: ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \
+odoc_dot.cmo : odoc_messages.cmo odoc_info.cmi
+odoc_dot.cmx : odoc_messages.cmx odoc_info.cmx
+odoc_env.cmo : ../typing/types.cmi ../typing/printtyp.cmi \
+    ../typing/predef.cmi ../typing/path.cmi odoc_name.cmi ../typing/btype.cmi \
+    odoc_env.cmi
+odoc_env.cmx : ../typing/types.cmx ../typing/printtyp.cmx \
+    ../typing/predef.cmx ../typing/path.cmx odoc_name.cmx ../typing/btype.cmx \
+    odoc_env.cmi
+odoc_exception.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi
+odoc_exception.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx
+odoc_gen.cmo : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \
+    odoc_html.cmo odoc_dot.cmo odoc_gen.cmi
+odoc_gen.cmx : odoc_texi.cmx odoc_module.cmx odoc_man.cmx odoc_latex.cmx \
+    odoc_html.cmx odoc_dot.cmx odoc_gen.cmi
+odoc_global.cmo : odoc_types.cmi odoc_messages.cmo odoc_config.cmi \
+    ../utils/clflags.cmi odoc_global.cmi
+odoc_global.cmx : odoc_types.cmx odoc_messages.cmx odoc_config.cmx \
+    ../utils/clflags.cmx odoc_global.cmi
+odoc_html.cmo : odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \
+    odoc_info.cmi odoc_global.cmi odoc_dag2html.cmi ../parsing/asttypes.cmi
+odoc_html.cmx : odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \
+    odoc_info.cmx odoc_global.cmx odoc_dag2html.cmx ../parsing/asttypes.cmi
+odoc_info.cmo : ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \
     odoc_type.cmo odoc_text.cmi odoc_str.cmi odoc_search.cmi odoc_scan.cmo \
     odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \
-    odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \
-    odoc_dep.cmo odoc_config.cmi odoc_comments.cmi odoc_class.cmo \
-    odoc_args.cmi odoc_analyse.cmi odoc_info.cmi
-odoc_info.cmx: ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \
+    odoc_misc.cmi odoc_global.cmi odoc_exception.cmo odoc_dep.cmo \
+    odoc_config.cmi odoc_comments.cmi odoc_class.cmo odoc_analyse.cmi \
+    odoc_info.cmi
+odoc_info.cmx : ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \
     odoc_type.cmx odoc_text.cmx odoc_str.cmx odoc_search.cmx odoc_scan.cmx \
     odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \
-    odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \
-    odoc_dep.cmx odoc_config.cmx odoc_comments.cmx odoc_class.cmx \
-    odoc_args.cmx odoc_analyse.cmx odoc_info.cmi
-odoc_inherit.cmo:
-odoc_inherit.cmx:
-odoc_latex.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \
+    odoc_misc.cmx odoc_global.cmx odoc_exception.cmx odoc_dep.cmx \
+    odoc_config.cmx odoc_comments.cmx odoc_class.cmx odoc_analyse.cmx \
+    odoc_info.cmi
+odoc_inherit.cmo :
+odoc_inherit.cmx :
+odoc_latex.cmo : odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \
+    odoc_info.cmi ../parsing/asttypes.cmi
+odoc_latex.cmx : odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \
+    odoc_info.cmx ../parsing/asttypes.cmi
+odoc_latex_style.cmo :
+odoc_latex_style.cmx :
+odoc_lexer.cmo : odoc_parser.cmi odoc_messages.cmo odoc_global.cmi \
+    odoc_comments_global.cmi
+odoc_lexer.cmx : odoc_parser.cmx odoc_messages.cmx odoc_global.cmx \
+    odoc_comments_global.cmx
+odoc_man.cmo : odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \
     odoc_info.cmi ../parsing/asttypes.cmi
-odoc_latex.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \
+odoc_man.cmx : odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \
     odoc_info.cmx ../parsing/asttypes.cmi
-odoc_latex_style.cmo:
-odoc_latex_style.cmx:
-odoc_lexer.cmo: odoc_parser.cmi odoc_messages.cmo odoc_comments_global.cmi \
-    odoc_args.cmi
-odoc_lexer.cmx: odoc_parser.cmx odoc_messages.cmx odoc_comments_global.cmx \
-    odoc_args.cmx
-odoc_man.cmo: odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \
-    odoc_info.cmi odoc_args.cmi ../parsing/asttypes.cmi
-odoc_man.cmx: odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \
-    odoc_info.cmx odoc_args.cmx ../parsing/asttypes.cmi
-odoc_merge.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \
+odoc_merge.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \
     odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \
-    odoc_exception.cmo odoc_class.cmo odoc_args.cmi odoc_merge.cmi
-odoc_merge.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \
+    odoc_global.cmi odoc_exception.cmo odoc_class.cmo odoc_merge.cmi
+odoc_merge.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \
     odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \
-    odoc_exception.cmx odoc_class.cmx odoc_args.cmx odoc_merge.cmi
-odoc_messages.cmo: odoc_global.cmi odoc_config.cmi ../utils/config.cmi
-odoc_messages.cmx: odoc_global.cmx odoc_config.cmx ../utils/config.cmx
-odoc_misc.cmo: ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \
+    odoc_global.cmx odoc_exception.cmx odoc_class.cmx odoc_merge.cmi
+odoc_messages.cmo : ../utils/config.cmi
+odoc_messages.cmx : ../utils/config.cmx
+odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \
     odoc_types.cmi odoc_messages.cmo ../parsing/longident.cmi \
     ../typing/ctype.cmi ../typing/btype.cmi odoc_misc.cmi
-odoc_misc.cmx: ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \
+odoc_misc.cmx : ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \
     odoc_types.cmx odoc_messages.cmx ../parsing/longident.cmx \
     ../typing/ctype.cmx ../typing/btype.cmx odoc_misc.cmi
-odoc_module.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
+odoc_module.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
     odoc_type.cmo odoc_name.cmi odoc_exception.cmo odoc_class.cmo
-odoc_module.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \
+odoc_module.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \
     odoc_type.cmx odoc_name.cmx odoc_exception.cmx odoc_class.cmx
-odoc_name.cmo: ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \
+odoc_name.cmo : ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \
     odoc_name.cmi
-odoc_name.cmx: ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \
+odoc_name.cmx : ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \
     odoc_name.cmi
-odoc_ocamlhtml.cmo:
-odoc_ocamlhtml.cmx:
-odoc_parameter.cmo: ../typing/types.cmi odoc_types.cmi
-odoc_parameter.cmx: ../typing/types.cmx odoc_types.cmx
-odoc_parser.cmo: odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi
-odoc_parser.cmx: odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi
-odoc_print.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_print.cmi
-odoc_print.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi
-odoc_scan.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \
+odoc_ocamlhtml.cmo :
+odoc_ocamlhtml.cmx :
+odoc_parameter.cmo : ../typing/types.cmi odoc_types.cmi
+odoc_parameter.cmx : ../typing/types.cmx odoc_types.cmx
+odoc_parser.cmo : odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi
+odoc_parser.cmx : odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi
+odoc_print.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_print.cmi
+odoc_print.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi
+odoc_scan.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \
     odoc_exception.cmo odoc_class.cmo
-odoc_scan.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \
+odoc_scan.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \
     odoc_exception.cmx odoc_class.cmx
-odoc_search.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \
+odoc_search.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \
     odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_exception.cmo \
     odoc_class.cmo odoc_search.cmi
-odoc_search.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \
+odoc_search.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \
     odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_exception.cmx \
     odoc_class.cmx odoc_search.cmi
-odoc_see_lexer.cmo: odoc_parser.cmi
-odoc_see_lexer.cmx: odoc_parser.cmx
-odoc_sig.cmo: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \
-    ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \
-    odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_misc.cmi \
-    odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_exception.cmo \
-    odoc_env.cmi odoc_class.cmo odoc_args.cmi ../utils/misc.cmi \
+odoc_see_lexer.cmo : odoc_parser.cmi
+odoc_see_lexer.cmx : odoc_parser.cmx
+odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \
+    ../typing/path.cmi ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi \
+    odoc_type.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \
+    odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \
+    odoc_exception.cmo odoc_env.cmi odoc_class.cmo ../utils/misc.cmi \
     ../parsing/location.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \
     odoc_sig.cmi
-odoc_sig.cmx: ../typing/types.cmx ../typing/typedtree.cmx ../typing/path.cmx \
-    ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \
-    odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_misc.cmx \
-    odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_exception.cmx \
-    odoc_env.cmx odoc_class.cmx odoc_args.cmx ../utils/misc.cmx \
+odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \
+    ../typing/path.cmx ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx \
+    odoc_type.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \
+    odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \
+    odoc_exception.cmx odoc_env.cmx odoc_class.cmx ../utils/misc.cmx \
     ../parsing/location.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \
     odoc_sig.cmi
-odoc_str.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \
+odoc_str.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \
     odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \
     odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \
     ../parsing/asttypes.cmi odoc_str.cmi
-odoc_str.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \
+odoc_str.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \
     odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \
     odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \
     ../parsing/asttypes.cmi odoc_str.cmi
-odoc_test.cmo: odoc_info.cmi
-odoc_test.cmx: odoc_info.cmx
-odoc_texi.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_info.cmi \
-    ../parsing/asttypes.cmi
-odoc_texi.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_info.cmx \
-    ../parsing/asttypes.cmi
-odoc_text.cmo: odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \
+odoc_test.cmo : odoc_info.cmi odoc_gen.cmi odoc_args.cmi
+odoc_test.cmx : odoc_info.cmx odoc_gen.cmx odoc_args.cmx
+odoc_texi.cmo : ../typing/types.cmi odoc_to_text.cmo odoc_messages.cmo \
+    odoc_info.cmi ../parsing/asttypes.cmi
+odoc_texi.cmx : ../typing/types.cmx odoc_to_text.cmx odoc_messages.cmx \
+    odoc_info.cmx ../parsing/asttypes.cmi
+odoc_text.cmo : odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \
     odoc_text.cmi
-odoc_text.cmx: odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \
+odoc_text.cmx : odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \
     odoc_text.cmi
-odoc_text_lexer.cmo: odoc_text_parser.cmi odoc_misc.cmi
-odoc_text_lexer.cmx: odoc_text_parser.cmx odoc_misc.cmx
-odoc_text_parser.cmo: odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi
-odoc_text_parser.cmx: odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi
-odoc_to_text.cmo: odoc_module.cmo odoc_messages.cmo odoc_info.cmi
-odoc_to_text.cmx: odoc_module.cmx odoc_messages.cmx odoc_info.cmx
-odoc_type.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi \
+odoc_text_lexer.cmo : odoc_text_parser.cmi odoc_misc.cmi
+odoc_text_lexer.cmx : odoc_text_parser.cmx odoc_misc.cmx
+odoc_text_parser.cmo : odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi
+odoc_text_parser.cmx : odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi
+odoc_to_text.cmo : odoc_module.cmo odoc_messages.cmo odoc_info.cmi
+odoc_to_text.cmx : odoc_module.cmx odoc_messages.cmx odoc_info.cmx
+odoc_type.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi \
     ../parsing/asttypes.cmi
-odoc_type.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx \
+odoc_type.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx \
     ../parsing/asttypes.cmi
-odoc_types.cmo: odoc_messages.cmo odoc_types.cmi
-odoc_types.cmx: odoc_messages.cmx odoc_types.cmi
-odoc_value.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \
+odoc_types.cmo : odoc_messages.cmo odoc_types.cmi
+odoc_types.cmx : odoc_messages.cmx odoc_types.cmi
+odoc_value.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \
     odoc_parameter.cmo odoc_name.cmi
-odoc_value.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \
+odoc_value.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_types.cmx \
     odoc_parameter.cmx odoc_name.cmx
-odoc_analyse.cmi: odoc_module.cmo odoc_args.cmi
-odoc_args.cmi: odoc_types.cmi odoc_module.cmo
-odoc_ast.cmi: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \
-    ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo
-odoc_comments.cmi: odoc_types.cmi odoc_module.cmo
-odoc_comments_global.cmi:
-odoc_config.cmi:
-odoc_cross.cmi: odoc_types.cmi odoc_module.cmo
-odoc_dag2html.cmi: odoc_info.cmi
-odoc_env.cmi: ../typing/types.cmi odoc_name.cmi
-odoc_global.cmi:
-odoc_info.cmi: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
+odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi
+odoc_args.cmi : odoc_gen.cmi
+odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \
+    ../typing/path.cmi ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi \
+    odoc_module.cmo
+odoc_comments.cmi : odoc_types.cmi odoc_module.cmo
+odoc_comments_global.cmi :
+odoc_config.cmi :
+odoc_cross.cmi : odoc_types.cmi odoc_module.cmo
+odoc_dag2html.cmi : odoc_info.cmi
+odoc_env.cmi : ../typing/types.cmi odoc_name.cmi
+odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \
+    odoc_html.cmo odoc_dot.cmo
+odoc_global.cmi : odoc_types.cmi
+odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \
     odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \
-    odoc_exception.cmo odoc_class.cmo
-odoc_merge.cmi: odoc_types.cmi odoc_module.cmo
-odoc_misc.cmi: ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi
-odoc_name.cmi: ../typing/path.cmi ../parsing/longident.cmi \
+    odoc_global.cmi odoc_exception.cmo odoc_class.cmo
+odoc_merge.cmi : odoc_types.cmi odoc_module.cmo
+odoc_misc.cmi : ../typing/types.cmi odoc_types.cmi ../parsing/longident.cmi
+odoc_name.cmi : ../typing/path.cmi ../parsing/longident.cmi \
     ../typing/ident.cmi
-odoc_parser.cmi: odoc_types.cmi
-odoc_print.cmi: ../typing/types.cmi
-odoc_search.cmi: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \
-    odoc_exception.cmo odoc_class.cmo
-odoc_sig.cmi: ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \
+odoc_parser.cmi : odoc_types.cmi
+odoc_print.cmi : ../typing/types.cmi
+odoc_search.cmi : odoc_value.cmo odoc_types.cmi odoc_type.cmo \
+    odoc_module.cmo odoc_exception.cmo odoc_class.cmo
+odoc_sig.cmi : ../typing/types.cmi ../parsing/parsetree.cmi odoc_types.cmi \
     odoc_type.cmo odoc_name.cmi odoc_module.cmo odoc_env.cmi odoc_class.cmo
-odoc_str.cmi: ../typing/types.cmi odoc_value.cmo odoc_type.cmo \
+odoc_str.cmi : ../typing/types.cmi odoc_value.cmo odoc_type.cmo \
     odoc_exception.cmo odoc_class.cmo
-odoc_text.cmi: odoc_types.cmi
-odoc_text_parser.cmi: odoc_types.cmi
-odoc_types.cmi:
+odoc_text.cmi : odoc_types.cmi
+odoc_text_parser.cmi : odoc_types.cmi
+odoc_types.cmi :

diff --git a/ocamldoc/.ignore b/ocamldoc/.ignore
new file mode 100644 (file)
index 0000000..720ee64
--- /dev/null
+++ b/ocamldoc/.ignore
@@ -0,0 +1,16 @@
+ocamldoc
+ocamldoc.opt
+odoc_crc.ml
+odoc_lexer.ml
+odoc_ocamlhtml.ml
+odoc_parser.ml
+odoc_parser.mli
+odoc_see_lexer.ml
+odoc_text_lexer.ml
+odoc_text_parser.ml
+odoc_text_parser.mli
+stdlib_man
+*.output
+test_stdlib
+test_latex
+test

diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile
index 852df926e31b21d4d066dbae856f86f8ea79d58f..d04809aa31147e2a6573c65323db94721c0b2999 100644 (file)
--- a/ocamldoc/Makefile
+++ b/ocamldoc/Makefile
@@ -1,5 +1,5 @@
 #(***********************************************************************)
-#(*                            OCamldoc                                 *)
+#(*                             OCamldoc                                *)
 #(*                                                                     *)
 #(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
 #(*                                                                     *)
@@ -47,6 +47,11 @@ INSTALL_CMIS=$(INSTALL_MLIS:.mli=.cmi)
 
 ODOC_TEST=odoc_test.cmo
 
+GENERATORS_CMOS= \
+       generators/odoc_todo.cmo \
+       generators/odoc_literate.cmo
+GENERATORS_CMXS=$(GENERATORS_CMOS:.cmo=.cmxs)
+
 
 # Compilation
 #############
@@ -72,8 +77,8 @@ COMPFLAGS=$(INCLUDES) -warn-error A
 LINKFLAGS=$(INCLUDES) -nostdlib
 
 CMOFILES= odoc_config.cmo \
-       odoc_global.cmo\
        odoc_messages.cmo\
+       odoc_global.cmo\
        odoc_types.cmo\
        odoc_misc.cmo\
        odoc_text_parser.cmo\
@@ -88,7 +93,6 @@ CMOFILES= odoc_config.cmo \
        odoc_module.cmo\
        odoc_print.cmo \
        odoc_str.cmo\
-       odoc_args.cmo\
        odoc_comments_global.cmo\
        odoc_parser.cmo\
        odoc_lexer.cmo\
@@ -121,6 +125,8 @@ EXECMOFILES=$(CMOFILES) \
        odoc_latex.cmo \
        odoc_texi.cmo \
        odoc_dot.cmo \
+       odoc_gen.cmo \
+       odoc_args.cmo\
        odoc.cmo
 
 EXECMXFILES= $(EXECMOFILES:.cmo=.cmx)
@@ -140,7 +146,6 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \
        $(OCAMLSRCDIR)/utils/warnings.cmo \
        $(OCAMLSRCDIR)/utils/ccomp.cmo \
        $(OCAMLSRCDIR)/utils/consistbl.cmo \
-       $(OCAMLSRCDIR)/parsing/linenum.cmo\
        $(OCAMLSRCDIR)/parsing/location.cmo\
        $(OCAMLSRCDIR)/parsing/longident.cmo \
        $(OCAMLSRCDIR)/parsing/syntaxerr.cmo \
@@ -188,14 +193,17 @@ STDLIB_MLIS=../stdlib/*.mli \
        ../otherlibs/bigarray/bigarray.mli \
        ../otherlibs/num/num.mli
 
-all: exe lib manpages
+all: exe lib generators manpages
 
 exe: $(OCAMLDOC)
 lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
+generators: $(GENERATORS_CMOS)
 
-opt.opt: exeopt libopt
+opt.opt: exeopt libopt generatorsopt
 exeopt: $(OCAMLDOC_OPT)
 libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
+generatorsopt: $(GENERATORS_CMXS)
+
 debug:
        make OCAMLPP=""
 
@@ -235,7 +243,7 @@ odoc_see_lexer.ml: odoc_see_lexer.mll
 # generic rules :
 #################
 
-.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx
+.SUFFIXES: .mll .mly .ml .mli .cmo .cmi .cmx .cmxs
 
 .ml.cmo:
        $(OCAMLC) $(OCAMLPP) $(COMPFLAGS) -c $<
@@ -246,6 +254,9 @@ odoc_see_lexer.ml: odoc_see_lexer.mll
 .ml.cmx:
        $(OCAMLOPT) $(OCAMLPP) $(COMPFLAGS) -c $<
 
+.ml.cmxs:
+       $(OCAMLOPT) -shared -o $@ $(OCAMLPP) $(COMPFLAGS) $<
+
 .mll.ml:
        $(OCAMLLEX) $<
 
@@ -282,6 +293,10 @@ installopt_really:
 test: dummy
        $(MKDIR) $@
        $(OCAMLDOC_RUN) -html -colorize-code -sort -d $@ $(INCLUDES) -dump $@/ocamldoc.odoc odoc*.ml odoc*.mli -v
+       $(MKDIR) $@-custom
+       $(OCAMLDOC_RUN) -colorize-code -sort -d $@-custom $(INCLUDES) \
+       -g generators/odoc_literate.cmo -g generators/odoc_todo.cmo \
+       -load $@/ocamldoc.odoc -v
 
 test_stdlib: dummy
        $(MKDIR) $@
@@ -339,6 +354,7 @@ clean:: dummy
        @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml
        @rm -f odoc_parser.ml odoc_parser.mli odoc_text_parser.ml odoc_text_parser.mli
        @rm -rf stdlib_man
+       @rm -f generators/*.cm[aiox] generators/*.[ao] generators/*.cmx[as]
 
 depend::
        $(OCAMLYACC) odoc_text_parser.mly

diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt
index 387aec928cc3391c1a194527a3d5affdec2128fe..a65b59738c1e92696ac6262867d932319c347d43 100644 (file)
--- a/ocamldoc/Makefile.nt
+++ b/ocamldoc/Makefile.nt
@@ -1,5 +1,5 @@
 #(***********************************************************************)
-#(*                            OCamldoc                                 *)
+#(*                             OCamldoc                                *)
 #(*                                                                     *)
 #(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
 #(*                                                                     *)
@@ -66,8 +66,8 @@ COMPFLAGS=$(INCLUDES)
 LINKFLAGS=$(INCLUDES) -nostdlib
 
 CMOFILES= odoc_config.cmo \
-       odoc_global.cmo\
        odoc_messages.cmo\
+       odoc_global.cmo\
        odoc_types.cmo\
        odoc_misc.cmo\
        odoc_text_parser.cmo\
@@ -82,7 +82,6 @@ CMOFILES= odoc_config.cmo \
        odoc_module.cmo\
        odoc_print.cmo \
        odoc_str.cmo\
-       odoc_args.cmo\
        odoc_comments_global.cmo\
        odoc_parser.cmo\
        odoc_lexer.cmo\
@@ -115,6 +114,8 @@ EXECMOFILES=$(CMOFILES)\
        odoc_latex.cmo\
        odoc_texi.cmo\
        odoc_dot.cmo\
+       odoc_gen.cmo\
+       odoc_args.cmo\
        odoc.cmo
 
 
@@ -135,7 +136,6 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.cmo \
        $(OCAMLSRCDIR)/utils/warnings.cmo \
        $(OCAMLSRCDIR)/utils/ccomp.cmo \
        $(OCAMLSRCDIR)/utils/consistbl.cmo \
-       $(OCAMLSRCDIR)/parsing/linenum.cmo\
        $(OCAMLSRCDIR)/parsing/location.cmo\
        $(OCAMLSRCDIR)/parsing/longident.cmo \
        $(OCAMLSRCDIR)/parsing/syntaxerr.cmo \

diff --git a/ocamldoc/generators/odoc_literate.ml b/ocamldoc/generators/odoc_literate.ml
new file mode 100644 (file)
index 0000000..6a1e078
--- /dev/null
+++ b/ocamldoc/generators/odoc_literate.ml
@@ -0,0 +1,207 @@
+(***********************************************************************)
+(*                             OCamldoc                                *)
+(*                                                                     *)
+(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+open Odoc_info
+module Naming = Odoc_html.Naming
+open Odoc_info.Value
+open Odoc_info.Module
+
+let p = Printf.bprintf
+let bp = Printf.bprintf
+let bs = Buffer.add_string
+
+module Html =
+  (val
+   (
+   match !Odoc_args.current_generator with
+     None -> (module Odoc_html.Generator : Odoc_html.Html_generator)
+   | Some (Odoc_gen.Html m) -> m
+   | _ ->
+       failwith
+         "A non-html generator is already set. Cannot install the Todo-list html generator"
+  ) : Odoc_html.Html_generator)
+;;
+
+module Generator =
+struct
+class html =
+  object (self)
+    inherit Html.html as html
+
+    method private html_of_module_comment b text =
+      let br1, br2 =
+        match text with
+          [(Odoc_info.Title (n, l_opt, t))] -> false, false
+        | (Odoc_info.Title (n, l_opt, t)) :: _ -> false, true
+        | _ -> true, true
+      in
+      if br1 then p b "<br/>";
+      self#html_of_text b text;
+      if br2 then p b "<br/><br/>\n"
+
+    method private html_of_Title b n l_opt t =
+      let label1 = self#create_title_label (n, l_opt, t) in
+      p b "<a name=\"%s\"></a>\n" (Naming.label_target label1);
+      p b "<h%d>" n;
+      self#html_of_text b t;
+      p b "</h%d>" n
+
+    val mutable code_id = 0
+    method private code_block b code =
+      code_id <- code_id + 1;
+      Printf.bprintf b
+      "<span class=\"code_expand\" onclick=\"if(document.getElementById('code%d').style.display=='none') {document.getElementById('code%d').style.display='block';} else {document.getElementById('code%d').style.display='none';}\"><img src=\"expand_collapse.png\" alt=\"+/-\"/></span>" code_id code_id code_id;
+      Printf.bprintf b "<div id=\"code%d\" class=\"codeblock\">" code_id;
+      self#html_of_code b code;
+      Printf.bprintf b "</div>"
+
+    (** Print html code for a value. *)
+    method private html_of_value b v =
+      Odoc_info.reset_type_names ();
+      self#html_of_info b v.val_info;
+      bs b "<pre>";
+      bs b (self#keyword "val");
+      bs b " ";
+      (* html mark *)
+      bp b "<a name=\"%s\"></a>" (Naming.value_target v);
+      bs b (self#escape (Name.simple v.val_name));
+      bs b " : ";
+      self#html_of_type_expr b (Name.father v.val_name) v.val_type;
+      bs b "</pre>";
+      (
+       if !Odoc_html.with_parameter_list then
+         self#html_of_parameter_list b (Name.father v.val_name) v.val_parameters
+       else
+         self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters
+      );
+      (
+       match v.val_code with
+         None -> ()
+       | Some code ->
+           self#code_block b code
+      )
+(*
+    (** Print html code for a module. *)
+    method private html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m =
+      let (html_file, _) = Naming.html_files m.m_name in
+      let father = Name.father m.m_name in
+      bs b "<pre>";
+      bs b ((self#keyword "module")^" ");
+      (
+       if with_link then
+         bp b "<a href=\"%s\">%s</a>" html_file (Name.simple m.m_name)
+       else
+         bs b (Name.simple m.m_name)
+      );
+(*      A remettre quand on compilera avec ocaml 3.10
+         (
+       match m.m_kind with
+         Module_functor _ when !Odoc_info.Args.html_short_functors  ->
+           ()
+
+       | _ -> *) bs b ": ";
+      (*
+      );
+      *)
+      self#html_of_module_kind b father ~modu: m m.m_kind;
+      bs b "</pre>";
+      if info && complete then
+        self#html_of_info ~indent: false b m.m_info
+
+*)
+    initializer
+      default_style_options <-
+        ["a:visited {color : #416DFF; text-decoration : none; }" ;
+          "a:link {color : #416DFF; text-decoration : none;}" ;
+          "a:hover {color : Red; text-decoration : none; background-color: #5FFF88}" ;
+          "a:active {color : Red; text-decoration : underline; }" ;
+          ".keyword { font-weight : bold ; color : Red }" ;
+          ".keywordsign { color : #C04600 }" ;
+          ".superscript { font-size : 4 }" ;
+          ".subscript { font-size : 4 }" ;
+          ".comment { color : Green }" ;
+          ".constructor { color : Blue }" ;
+          ".type { color : #5C6585 }" ;
+          ".string { color : Maroon }" ;
+          ".warning { color : Red ; font-weight : bold }" ;
+          ".info { margin-top: 8px; }";
+          ".param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em }" ;
+          ".code { color : #465F91 ; }" ;
+          "h1 { font-size : 20pt ; text-align: center; }" ;
+
+          "h2 { font-size : 20pt ; border: 1px solid #000000; "^
+            "margin-top: 5px; margin-bottom: 2px;"^
+            "text-align: center; background-color: #90BDFF ;"^
+            "padding: 2px; }" ;
+
+          "h3 { font-size : 20pt ; border: 1px solid #000000; "^
+            "margin-top: 5px; margin-bottom: 2px;"^
+            "text-align: center; background-color: #90DDFF ;"^
+            "padding: 2px; }" ;
+
+          "h4 { font-size : 20pt ; border: 1px solid #000000; "^
+            "margin-top: 5px; margin-bottom: 2px;"^
+            "text-align: center; background-color: #90EDFF ;"^
+            "padding: 2px; }" ;
+
+          "h5 { font-size : 20pt ; border: 1px solid #000000; "^
+            "margin-top: 5px; margin-bottom: 2px;"^
+            "text-align: center; background-color: #90FDFF ;"^
+            "padding: 2px; }" ;
+
+          "h6 { font-size : 20pt ; border: 1px solid #000000; "^
+            "margin-top: 5px; margin-bottom: 2px;"^
+            "text-align: center; background-color: #C0FFFF ; "^
+            "padding: 2px; }" ;
+
+          "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^
+            "margin-top: 5px; margin-bottom: 2px;"^
+            "text-align: center; background-color: #E0FFFF ; "^
+            "padding: 2px; }" ;
+
+          "div.h8 { font-size : 20pt ; border: 1px solid #000000; "^
+            "margin-top: 5px; margin-bottom: 2px;"^
+            "text-align: center; background-color: #F0FFFF ; "^
+            "padding: 2px; }" ;
+
+          "div.h9 { font-size : 20pt ; border: 1px solid #000000; "^
+            "margin-top: 5px; margin-bottom: 2px;"^
+            "text-align: center; background-color: #FFFFFF ; "^
+            "padding: 2px; }" ;
+
+          ".typetable { border-style : hidden }" ;
+          ".indextable { border-style : hidden }" ;
+          ".paramstable { border-style : hidden ; padding: 5pt 5pt}" ;
+          "body { background-color : White }" ;
+          "tr { background-color : White }" ;
+          "td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;}" ;
+          "pre { margin-bottom: 4px ; margin-left: 1em; "^
+            "border-color: #27408b; border-style: solid; "^
+            "border-width: 1px 1px 1px 3px; "^
+            "padding: 4px; }" ;
+          "div.sig_block {margin-left: 2em}" ;
+
+          "div.codeblock { "^
+            "margin-left: 2em; margin-right: 1em; padding: 6px; "^
+            "margin-bottom: 8px; display: none; "^
+            "border-width: 1px 1px 1px 3px; border-style: solid; border-color: grey; }" ;
+
+          "span.code_expand { color: blue; text-decoration: underline; cursor: pointer; "^
+          "margin-left: 1em ; } ";
+        ];
+  end
+end
+
+let _ = Odoc_args.set_generator
+ (Odoc_gen.Html (module Generator : Odoc_html.Html_generator))
+ ;;

diff --git a/ocamldoc/generators/odoc_todo.ml b/ocamldoc/generators/odoc_todo.ml
new file mode 100644 (file)
index 0000000..7c025e1
--- /dev/null
+++ b/ocamldoc/generators/odoc_todo.ml
@@ -0,0 +1,225 @@
+(***********************************************************************)
+(*                             OCamldoc                                *)
+(*                                                                     *)
+(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
+(*                                                                     *)
+(*  Copyright 2010 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(** An OCamldoc generator to retrieve information in "todo" tags and
+   generate an html page with all todo items. *)
+
+open Odoc_info
+module Naming = Odoc_html.Naming
+open Odoc_info.Value
+open Odoc_info.Module
+open Odoc_info.Type
+open Odoc_info.Exception
+open Odoc_info.Class
+
+let p = Printf.bprintf
+
+module Html =
+  (val
+   (
+   match !Odoc_args.current_generator with
+     None -> (module Odoc_html.Generator : Odoc_html.Html_generator)
+   | Some (Odoc_gen.Html m) -> m
+   | _ ->
+       failwith
+         "A non-html generator is already set. Cannot install the Todo-list html generator"
+  ) : Odoc_html.Html_generator)
+;;
+
+module Generator =
+struct
+  class scanner html =
+    object (self)
+      inherit Odoc_info.Scan.scanner
+
+    val b = Buffer.create 256
+    method buffer = b
+
+    method private gen_if_tag name target info_opt =
+      match info_opt with
+        None -> ()
+      |        Some i ->
+          let l =
+            List.fold_left
+              (fun acc (t, text) ->
+                 match t with
+                   "todo" ->
+                     begin
+                       match text with
+                         (Odoc_info.Code s) :: q ->
+                           (
+                            try
+                              let n = int_of_string s in
+                              let head =
+                                Odoc_info.Code (Printf.sprintf "[%d] " n)
+                              in
+                              (Some n, head::q) :: acc
+                            with _ -> (None, text) :: acc
+                           )
+                       | _ -> (None, text) :: acc
+
+                     end
+                 |     _ -> acc
+              )
+              []
+              i.i_custom
+          in
+          match l with
+            [] -> ()
+          | _ ->
+              let l = List.sort
+                (fun a b ->
+                   match a, b with
+                     (None, _), _ -> -1
+                   | _, (None, _) -> 1
+                   | (Some n1, _), (Some n2, _) -> compare n1 n2
+                )
+                l
+              in
+              p b "<pre><a href=\"%s\">%s</a></pre><div class=\"info\">"
+                target name;
+              let col = function
+                None -> "#000000"
+              | Some 1 -> "#FF0000"
+              | Some 2 -> "#AA5555"
+              | Some 3 -> "#44BB00"
+              | Some n -> Printf.sprintf "#%2x0000" (0xAA - (n * 0x10))
+              in
+              List.iter
+                (fun (n, e) ->
+                   Printf.bprintf b "<span style=\"color: %s\">" (col n);
+                   html#html_of_text b e;
+                   p b "</span><br/>\n";
+                )
+                l;
+              p b "</div>"
+
+    method scan_value v =
+      self#gen_if_tag
+        v.val_name
+        (Odoc_html.Naming.complete_value_target v)
+        v.val_info
+
+    method scan_type t =
+      self#gen_if_tag
+        t.ty_name
+        (Odoc_html.Naming.complete_type_target t)
+        t.ty_info
+
+    method scan_exception e =
+      self#gen_if_tag
+        e.ex_name
+        (Odoc_html.Naming.complete_exception_target e)
+        e.ex_info
+
+    method scan_attribute a =
+      self#gen_if_tag
+        a.att_value.val_name
+        (Odoc_html.Naming.complete_attribute_target a)
+        a.att_value.val_info
+
+    method scan_method m =
+      self#gen_if_tag
+        m.met_value.val_name
+        (Odoc_html.Naming.complete_method_target m)
+        m.met_value.val_info
+
+   (** This method scan the elements of the given module. *)
+    method scan_module_elements m =
+      List.iter
+        (fun ele ->
+          match ele with
+            Odoc_module.Element_module m -> self#scan_module m
+          | Odoc_module.Element_module_type mt -> self#scan_module_type mt
+          | Odoc_module.Element_included_module im -> self#scan_included_module im
+          | Odoc_module.Element_class c -> self#scan_class c
+          | Odoc_module.Element_class_type ct -> self#scan_class_type ct
+          | Odoc_module.Element_value v -> self#scan_value v
+          | Odoc_module.Element_exception e -> self#scan_exception e
+          | Odoc_module.Element_type t -> self#scan_type t
+          | Odoc_module.Element_module_comment t -> self#scan_module_comment t
+        )
+        (Odoc_module.module_elements ~trans: false m)
+
+    method scan_included_module _ = ()
+
+    method scan_class_pre c =
+      self#gen_if_tag
+        c.cl_name
+        (fst (Odoc_html.Naming.html_files c.cl_name))
+        c.cl_info;
+      true
+
+    method scan_class_type_pre ct =
+      self#gen_if_tag
+        ct.clt_name
+        (fst (Odoc_html.Naming.html_files ct.clt_name))
+        ct.clt_info;
+      true
+
+    method scan_module_pre m =
+      self#gen_if_tag
+        m.m_name
+        (fst (Odoc_html.Naming.html_files m.m_name))
+        m.m_info;
+      true
+
+    method scan_module_type_pre mt =
+      self#gen_if_tag
+        mt.mt_name
+        (fst (Odoc_html.Naming.html_files mt.mt_name))
+        mt.mt_info;
+      true
+  end
+
+  class html : Html.html =
+    object (self)
+      inherit Html.html as html
+
+      (** we have to hack a little because we cannot inherit from
+             scanner, since public method cannot be hidden and
+             our html class must respect the type of the default
+             html generator class *)
+      val mutable scanner = new scanner (new Html.html )
+
+      method generate modules =
+      (* prevent having the 'todo' tag signaled as not handled *)
+      tag_functions <-  ("todo", (fun _ -> "")) :: tag_functions;
+      (* generate doc as usual *)
+      html#generate modules;
+      (* then retrieve the todo tags and generate the todo.html page *)
+      let title =
+        match !Odoc_info.Global.title with
+          None -> ""
+        | Some s -> s
+      in
+      let b = Buffer.create 512 in
+      p b "<html>";
+      self#print_header b title ;
+      p b "<body><h1>%s</h1>" title;
+      scanner#scan_module_list modules;
+      Buffer.add_buffer b scanner#buffer;
+      let oc = open_out
+          (Filename.concat !Odoc_info.Global.target_dir "todo.html")
+      in
+      Buffer.output_buffer oc b;
+      close_out oc
+
+     initializer
+       scanner <- new scanner self
+  end
+end
+
+let _ = Odoc_args.set_generator
+ (Odoc_gen.Html (module Generator : Odoc_html.Html_generator))
+ ;;

diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva
index 454cee9e7e295cd3c7f21c7ffdf02e667a4055b3..1d0eb60d4f26d787490edcda05f30c894337e018 100644 (file)
--- a/ocamldoc/ocamldoc.hva
+++ b/ocamldoc/ocamldoc.hva
@@ -1,3 +1,14 @@
+%(***********************************************************************)
+%(*                             OCamldoc                                *)
+%(*                                                                     *)
+%(*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
+%(*                                                                     *)
+%(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+%(*  en Automatique.  All rights reserved.  This file is distributed    *)
+%(*  under the terms of the Q Public License version 1.0.               *)
+%(*                                                                     *)
+%(***********************************************************************)
+
 \usepackage{alltt}
 \newenvironment{ocamldoccode}{\begin{alltt}}{\end{alltt}}
 \newenvironment{ocamldocdescription}{\begin{quote}}{\end{quote}}

diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml
index 5ecf70515cf614af7e5dabcccc15b39014318c2d..54b84db93c71bc9d1ad8f2003043a547655e560c 100644 (file)
--- a/ocamldoc/odoc.ml
+++ b/ocamldoc/odoc.ml
@@ -11,7 +11,8 @@
 
 (* $Id$ *)
 
-(** Main module for bytecode. *)
+(** Main module for bytecode.
+@todo coucou le todo*)
 
 open Config
 open Clflags
@@ -25,21 +26,20 @@ let print_DEBUG s = print_string s ; print_newline ()
 
 (* we check if we must load a module given on the command line *)
 let arg_list = Array.to_list Sys.argv
-let (cm_opt, paths) =
-  let rec iter (f_opt, inc) = function
-      [] | _ :: [] -> (f_opt, inc)
+let (plugins, paths) =
+  let rec iter (files, incs) = function
+      [] | _ :: [] -> (List.rev files, List.rev incs)
     | "-g" :: file :: q when
         ((Filename.check_suffix file "cmo") or
          (Filename.check_suffix file "cma") or
-           (Filename.check_suffix file "cmxs")) &
-        (f_opt = None) ->
-      iter (Some file, inc) q
+           (Filename.check_suffix file "cmxs")) ->
+      iter (file :: files, incs) q
   | "-i" :: dir :: q ->
-      iter (f_opt, inc @ [dir]) q
+      iter (files, dir :: incs) q
   | _ :: q ->
-        iter (f_opt, inc) q
+        iter (files, incs) q
   in
-  iter (None, []) arg_list
+  iter ([], []) arg_list
 
 let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load"
 
@@ -63,41 +63,29 @@ let get_real_filename name =
           failwith (M.file_not_found_in_paths paths name)
      )
 
-let _ =
-  match cm_opt with
-    None ->
-      ()
-  | Some file ->
-      let file = Dynlink.adapt_filename file in
-      Dynlink.allow_unsafe_modules true;
-      try
-        let real_file = get_real_filename file in
-        ignore(Dynlink.loadfile real_file)
-      with
-        Dynlink.Error e ->
-          prerr_endline (Odoc_messages.load_file_error file (Dynlink.error_message e)) ;
-          exit 1
-      | Not_found ->
-          prerr_endline (Odoc_messages.load_file_error file "Not_found");
-          exit 1
-      | Sys_error s
-      | Failure s ->
-          prerr_endline (Odoc_messages.load_file_error file s);
-          exit 1
-
-let _ = print_DEBUG "Fin du chargement dynamique eventuel"
-
-let default_html_generator = new Odoc_html.html
-let default_latex_generator = new Odoc_latex.latex
-let default_texi_generator = new Odoc_texi.texi
-let default_man_generator = new Odoc_man.man
-let default_dot_generator = new Odoc_dot.dot
-let _ = Odoc_args.parse
-    (default_html_generator :> Odoc_args.doc_generator)
-    (default_latex_generator :> Odoc_args.doc_generator)
-    (default_texi_generator :> Odoc_args.doc_generator)
-    (default_man_generator :> Odoc_args.doc_generator)
-    (default_dot_generator :> Odoc_args.doc_generator)
+let load_plugin file =
+  let file = Dynlink.adapt_filename file in
+  Dynlink.allow_unsafe_modules true;
+  try
+    let real_file = get_real_filename file in
+    ignore(Dynlink.loadfile real_file)
+  with
+    Dynlink.Error e ->
+      prerr_endline (Odoc_messages.load_file_error file (Dynlink.error_message e)) ;
+      exit 1
+  | Not_found ->
+      prerr_endline (Odoc_messages.load_file_error file "Not_found");
+      exit 1
+  | Sys_error s
+  | Failure s ->
+      prerr_endline (Odoc_messages.load_file_error file s);
+      exit 1
+;;
+List.iter load_plugin plugins;;
+
+let () = print_DEBUG "Fin du chargement dynamique eventuel"
+
+let () = Odoc_args.parse ()
 
 
 let loaded_modules =
@@ -114,13 +102,13 @@ let loaded_modules =
            incr Odoc_global.errors ;
            []
        )
-       !Odoc_args.load
+       !Odoc_global.load
     )
 
-let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_args.files
+let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_global.files
 
 let _ =
-  match !Odoc_args.dump with
+  match !Odoc_global.dump with
     None -> ()
   | Some f ->
       try Odoc_analyse.dump_modules f modules
@@ -128,13 +116,15 @@ let _ =
         prerr_endline s ;
         incr Odoc_global.errors
 
+
 let _ =
-  match !Odoc_args.doc_generator with
+  match !Odoc_args.current_generator with
     None ->
       ()
   | Some gen ->
+      let generator = Odoc_gen.get_minimal_generator gen in
       Odoc_info.verbose Odoc_messages.generating_doc;
-      gen#generate modules;
+      generator#generate modules;
       Odoc_info.verbose Odoc_messages.ok
 
 let _ =

diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml
index 143da019d34fa55f0b0d7bd287cd1b4c20eac729..bbcfaf93d3aed1981160f569f63e6fe26acaf3a7 100644 (file)
--- a/ocamldoc/odoc_analyse.ml
+++ b/ocamldoc/odoc_analyse.ml
@@ -73,15 +73,14 @@ let parse_file inputfile parse_fun ast_magic =
   let ic = open_in_bin inputfile in
   let is_ast_file =
     try
-      let buffer = String.create (String.length ast_magic) in
-      really_input ic buffer 0 (String.length ast_magic);
+      let buffer = Misc.input_bytes ic (String.length ast_magic) in
       if buffer = ast_magic then true
       else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
         raise Outdated_version
       else false
     with
       Outdated_version ->
-        fatal_error "Ocaml and preprocessor have incompatible versions"
+        fatal_error "OCaml and preprocessor have incompatible versions"
     | _ -> false
   in
   let ast =
@@ -203,18 +202,18 @@ let process_error exn =
 
 (** Process the given file, according to its extension. Return the Module.t created, if any.*)
 let process_file ppf sourcefile =
-  if !Odoc_args.verbose then
+  if !Odoc_global.verbose then
     (
      let f = match sourcefile with
-       Odoc_args.Impl_file f
-     | Odoc_args.Intf_file f -> f
-     | Odoc_args.Text_file f -> f
+       Odoc_global.Impl_file f
+     | Odoc_global.Intf_file f -> f
+     | Odoc_global.Text_file f -> f
      in
      print_string (Odoc_messages.analysing f) ;
      print_newline ();
     );
   match sourcefile with
-    Odoc_args.Impl_file file ->
+    Odoc_global.Impl_file file ->
       (
        Location.input_name := file;
        try
@@ -228,7 +227,7 @@ let process_file ppf sourcefile =
              in
              file_module.Odoc_module.m_top_deps <- Odoc_dep.impl_dependencies parsetree ;
 
-             if !Odoc_args.verbose then
+             if !Odoc_global.verbose then
                (
                 print_string Odoc_messages.ok;
                 print_newline ()
@@ -246,7 +245,7 @@ let process_file ppf sourcefile =
            incr Odoc_global.errors ;
            None
       )
-  | Odoc_args.Intf_file file ->
+  | Odoc_global.Intf_file file ->
       (
        Location.input_name := file;
        try
@@ -257,7 +256,7 @@ let process_file ppf sourcefile =
 
          file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ;
 
-         if !Odoc_args.verbose then
+         if !Odoc_global.verbose then
            (
             print_string Odoc_messages.ok;
             print_newline ()
@@ -275,7 +274,7 @@ let process_file ppf sourcefile =
            incr Odoc_global.errors ;
            None
       )
-  | Odoc_args.Text_file file ->
+  | Odoc_global.Text_file file ->
       Location.input_name := file;
       try
         let mod_name =
@@ -474,20 +473,20 @@ let analyse_files ?(init=[]) files =
   in
   (* Remove elements between the stop special comments, if needed. *)
   let modules =
-    if !Odoc_args.no_stop then
+    if !Odoc_global.no_stop then
       modules_pre
     else
       remove_elements_between_stop modules_pre
   in
 
 
-  if !Odoc_args.verbose then
+  if !Odoc_global.verbose then
     (
      print_string Odoc_messages.merging;
      print_newline ()
     );
-  let merged_modules = Odoc_merge.merge !Odoc_args.merge_options modules in
-  if !Odoc_args.verbose then
+  let merged_modules = Odoc_merge.merge !Odoc_global.merge_options modules in
+  if !Odoc_global.verbose then
     (
      print_string Odoc_messages.ok;
      print_newline ();
@@ -499,20 +498,20 @@ let analyse_files ?(init=[]) files =
        merged_modules
     )
   in
-  if !Odoc_args.verbose then
+  if !Odoc_global.verbose then
     (
      print_string Odoc_messages.cross_referencing;
      print_newline ()
     );
   let _ = Odoc_cross.associate modules_list in
 
-  if !Odoc_args.verbose then
+  if !Odoc_global.verbose then
     (
      print_string Odoc_messages.ok;
      print_newline ();
     );
 
-  if !Odoc_args.sort_modules then
+  if !Odoc_global.sort_modules then
     Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules
   else
     merged_modules

diff --git a/ocamldoc/odoc_analyse.mli b/ocamldoc/odoc_analyse.mli
index e9be5ba5b768cdfc1998d74c9f9a3a01ffa73cb1..b927ad4a069bd7e8d9d406cd4756e4ab7f7b6357 100644 (file)
--- a/ocamldoc/odoc_analyse.mli
+++ b/ocamldoc/odoc_analyse.mli
@@ -19,7 +19,7 @@
 *)
 val analyse_files :
     ?init: Odoc_module.t_module list ->
-      Odoc_args.source_file list ->
+      Odoc_global.source_file list ->
         Odoc_module.t_module list
 
 (** Dump of a list of modules into a file.

diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml
index fa693d69e4b1f8b8dcb07ba0998aba3662cc8871..bee38930adfa215e2a84f0dc0eb9df52f110fd6a 100644 (file)
--- a/ocamldoc/odoc_args.ml
+++ b/ocamldoc/odoc_args.ml
@@ -13,40 +13,99 @@
 
 (** Command-line arguments. *)
 
-open Clflags
-
 module M = Odoc_messages
 
-type source_file =
-    Impl_file of string
-  | Intf_file of string
-  | Text_file of string
-
-let include_dirs = Clflags.include_dirs
-
-class type doc_generator =
-    object
-      method generate : Odoc_module.t_module list -> unit
-    end
-
-let doc_generator = ref (None : doc_generator option)
-
-let merge_options = ref ([] : Odoc_types.merge_option list)
-
-let out_file = ref M.default_out_file
-
-let dot_include_all = ref false
-
-let dot_types = ref false
-
-let dot_reduce = ref false
-
-let dot_colors  = ref (List.flatten M.default_dot_colors)
-
-let man_suffix = ref M.default_man_suffix
-let man_section = ref M.default_man_section
-
-let man_mini = ref false
+let current_generator = ref (None : Odoc_gen.generator option)
+
+let get_html_generator () =
+  match !current_generator with
+    None -> (module Odoc_html.Generator : Odoc_html.Html_generator)
+  | Some (Odoc_gen.Html m) -> m
+  | Some _ -> failwith (M.current_generator_is_not "html")
+;;
+
+let get_latex_generator () =
+  match !current_generator with
+    None -> (module Odoc_latex.Generator : Odoc_latex.Latex_generator)
+  | Some (Odoc_gen.Latex m) -> m
+  | Some _ -> failwith (M.current_generator_is_not "latex")
+;;
+
+let get_texi_generator () =
+  match !current_generator with
+    None -> (module Odoc_texi.Generator : Odoc_texi.Texi_generator)
+  | Some (Odoc_gen.Texi m) -> m
+  | Some _ -> failwith (M.current_generator_is_not "texi")
+;;
+
+let get_man_generator () =
+  match !current_generator with
+    None -> (module Odoc_man.Generator : Odoc_man.Man_generator)
+  | Some (Odoc_gen.Man m) -> m
+  | Some _ -> failwith (M.current_generator_is_not "man")
+;;
+
+let get_dot_generator () =
+  match !current_generator with
+    None -> (module Odoc_dot.Generator : Odoc_dot.Dot_generator)
+  | Some (Odoc_gen.Dot m) -> m
+  | Some _ -> failwith (M.current_generator_is_not "dot")
+;;
+
+let get_base_generator () =
+  match !current_generator with
+    None -> (module Odoc_gen.Base_generator : Odoc_gen.Base)
+  | Some (Odoc_gen.Base m) -> m
+  | Some _ -> failwith (M.current_generator_is_not "base")
+;;
+
+let extend_html_generator f =
+  let current = get_html_generator () in
+  let module Current = (val current : Odoc_html.Html_generator) in
+  let module F = (val f : Odoc_gen.Html_functor) in
+  let module M = F(Current) in
+  current_generator := Some (Odoc_gen.Html (module M : Odoc_html.Html_generator))
+;;
+
+let extend_latex_generator f =
+  let current = get_latex_generator () in
+  let module Current = (val current : Odoc_latex.Latex_generator) in
+  let module F = (val f : Odoc_gen.Latex_functor) in
+  let module M = F(Current) in
+  current_generator := Some(Odoc_gen.Latex (module M : Odoc_latex.Latex_generator))
+;;
+
+let extend_texi_generator f =
+  let current = get_texi_generator () in
+  let module Current = (val current : Odoc_texi.Texi_generator) in
+  let module F = (val f : Odoc_gen.Texi_functor) in
+  let module M = F(Current) in
+  current_generator := Some(Odoc_gen.Texi (module M : Odoc_texi.Texi_generator))
+;;
+
+let extend_man_generator f =
+  let current = get_man_generator () in
+  let module Current = (val current : Odoc_man.Man_generator) in
+  let module F = (val f : Odoc_gen.Man_functor) in
+  let module M = F(Current) in
+  current_generator := Some(Odoc_gen.Man (module M : Odoc_man.Man_generator))
+;;
+
+let extend_dot_generator f =
+  let current = get_dot_generator () in
+  let module Current = (val current : Odoc_dot.Dot_generator) in
+  let module F = (val f : Odoc_gen.Dot_functor) in
+  let module M = F(Current) in
+  current_generator := Some (Odoc_gen.Dot (module M : Odoc_dot.Dot_generator))
+;;
+
+let extend_base_generator f =
+  let current = get_base_generator () in
+  let module Current = (val current : Odoc_gen.Base) in
+  let module F = (val f : Odoc_gen.Base_functor) in
+  let module M = F(Current) in
+  current_generator := Some (Odoc_gen.Base (module M : Odoc_gen.Base))
+;;
 
 (** Analysis of a string defining options. Return the list of
    options according to the list giving associations between
@@ -81,79 +140,6 @@ let analyse_merge_options s =
   in
   analyse_option_string l s
 
-let classic = Clflags.classic
-
-let dump = ref (None : string option)
-
-let load = ref ([] : string list)
-
-(** Allow arbitrary recursive types. *)
-let recursive_types = Clflags.recursive_types
-
-let verbose = ref false
-
-(** Optional preprocessor command. *)
-let preprocessor = Clflags.preprocessor
-
-let sort_modules = ref false
-
-let no_custom_tags = ref false
-
-let no_stop = ref false
-
-let remove_stars = ref false
-
-let keep_code = ref false
-
-let inverse_merge_ml_mli = ref false
-
-let filter_with_module_constraints = ref true
-
-let title = ref (None : string option)
-
-let intro_file = ref (None : string option)
-
-let with_parameter_list = ref false
-
-let hidden_modules = ref ([] : string list)
-
-let target_dir = ref Filename.current_dir_name
-
-let css_style = ref None
-
-let index_only = ref false
-
-let colorize_code = ref false
-
-let html_short_functors = ref false
-
-let charset = ref "iso-8859-1"
-
-let with_header = ref true
-
-let with_trailer = ref true
-
-let separate_files = ref false
-
-let latex_titles = ref [
-  1, "section" ;
-  2, "subsection" ;
-  3, "subsubsection" ;
-  4, "paragraph" ;
-  5, "subparagraph" ;
-]
-
-let with_toc = ref true
-
-let with_index = ref true
-
-let esc_8bits = ref false
-
-let info_section = ref "Objective Caml"
-
-let info_entry = ref []
-
-let files = ref []
 
 let f_latex_title s =
   try
@@ -161,8 +147,8 @@ let f_latex_title s =
     let n = int_of_string (String.sub s 0 pos) in
     let len = String.length s in
     let command = String.sub s (pos + 1) (len - pos - 1) in
-    latex_titles := List.remove_assoc n !latex_titles ;
-    latex_titles := (n, command) :: !latex_titles
+    Odoc_latex.latex_titles := List.remove_assoc n !Odoc_latex.latex_titles ;
+    Odoc_latex.latex_titles := (n, command) :: !Odoc_latex.latex_titles
   with
     Not_found
   | Invalid_argument _ ->
@@ -178,83 +164,77 @@ let add_hidden_modules s =
         "" -> ()
       | _ ->
           match name.[0] with
-            'A'..'Z' -> hidden_modules := name :: !hidden_modules
+            'A'..'Z' -> Odoc_global.hidden_modules := name :: !Odoc_global.hidden_modules
           | _ ->
               incr Odoc_global.errors;
               prerr_endline (M.not_a_module_name name)
     )
     l
 
-let latex_value_prefix = ref M.default_latex_value_prefix
-let latex_type_prefix = ref M.default_latex_type_prefix
-let latex_exception_prefix = ref M.default_latex_exception_prefix
-let latex_module_prefix = ref M.default_latex_module_prefix
-let latex_module_type_prefix = ref M.default_latex_module_type_prefix
-let latex_class_prefix = ref M.default_latex_class_prefix
-let latex_class_type_prefix = ref M.default_latex_class_type_prefix
-let latex_attribute_prefix = ref M.default_latex_attribute_prefix
-let latex_method_prefix = ref M.default_latex_method_prefix
-
-let set_doc_generator (dg_opt : doc_generator option) = doc_generator := dg_opt
-
-(** The default html generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_html_generator = ref (None : doc_generator option)
-
-(** The default latex generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_latex_generator = ref (None : doc_generator option)
-
-(** The default texinfo generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_texi_generator = ref (None : doc_generator option)
-
-(** The default man pages generator. Initialized in the parse function, to be used during the command line analysis.*)
-let default_man_generator = ref (None : doc_generator option)
-
-(** The default dot generator. Initialized in the parse function, to be used during  the command line analysis.*)
-let default_dot_generator = ref (None : doc_generator option)
+let set_generator (g : Odoc_gen.generator) = current_generator := Some g
 
 (** The default option list *)
 let default_options = [
   "-version", Arg.Unit (fun () -> print_string M.message_version ; print_newline () ; exit 0) , M.option_version ;
   "-vnum", Arg.Unit (fun () -> print_string M.config_version ;
                                print_newline () ; exit 0) , M.option_version ;
-  "-v", Arg.Unit (fun () -> verbose := true), M.verbose_mode ;
-  "-I", Arg.String (fun s -> include_dirs := (Misc.expand_directory Config.standard_library s) :: !include_dirs), M.include_dirs ;
-  "-pp", Arg.String (fun s -> preprocessor := Some s), M.preprocess ;
-  "-impl", Arg.String (fun s -> files := !files @ [Impl_file s]), M.option_impl ;
-  "-intf", Arg.String (fun s -> files := !files @ [Intf_file s]), M.option_intf ;
-  "-text", Arg.String (fun s -> files := !files @ [Text_file s]), M.option_text ;
-  "-rectypes", Arg.Set recursive_types, M.rectypes ;
-  "-nolabels", Arg.Unit (fun () -> classic := true), M.nolabels ;
+  "-v", Arg.Unit (fun () -> Odoc_global.verbose := true), M.verbose_mode ;
+  "-I", Arg.String (fun s ->
+       Odoc_global.include_dirs :=
+         (Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs),
+    M.include_dirs ;
+  "-pp", Arg.String (fun s -> Odoc_global.preprocessor := Some s), M.preprocess ;
+  "-impl", Arg.String (fun s ->
+       Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]),
+    M.option_impl ;
+    "-intf", Arg.String (fun s ->
+       Odoc_global.files := !Odoc_global.files @ [Odoc_global.Intf_file s]),
+    M.option_intf ;
+  "-text", Arg.String (fun s ->
+       Odoc_global.files := !Odoc_global.files @ [Odoc_global.Text_file s]),
+    M.option_text ;
+  "-rectypes", Arg.Set Odoc_global.recursive_types, M.rectypes ;
+  "-nolabels", Arg.Unit (fun () -> Odoc_global.classic := true), M.nolabels ;
   "-warn-error", Arg.Set Odoc_global.warn_error, M.werr ;
   "-hide-warnings", Arg.Clear Odoc_config.print_warnings, M.hide_warnings ;
-  "-o", Arg.String (fun s -> out_file := s), M.out_file ;
-  "-d", Arg.String (fun s -> target_dir := s), M.target_dir ;
-  "-sort", Arg.Unit (fun () -> sort_modules := true), M.sort_modules ;
-  "-no-stop", Arg.Set no_stop, M.no_stop ;
-  "-no-custom-tags", Arg.Set no_custom_tags, M.no_custom_tags ;
-  "-stars", Arg.Set remove_stars, M.remove_stars ;
-  "-inv-merge-ml-mli", Arg.Set inverse_merge_ml_mli, M.inverse_merge_ml_mli ;
-  "-no-module-constraint-filter", Arg.Clear filter_with_module_constraints,
+  "-o", Arg.String (fun s -> Odoc_global.out_file := s), M.out_file ;
+  "-d", Arg.String (fun s -> Odoc_global.target_dir := s), M.target_dir ;
+  "-sort", Arg.Unit (fun () -> Odoc_global.sort_modules := true), M.sort_modules ;
+  "-no-stop", Arg.Set Odoc_global.no_stop, M.no_stop ;
+  "-no-custom-tags", Arg.Set Odoc_global.no_custom_tags, M.no_custom_tags ;
+  "-stars", Arg.Set Odoc_global.remove_stars, M.remove_stars ;
+  "-inv-merge-ml-mli", Arg.Set Odoc_global.inverse_merge_ml_mli, M.inverse_merge_ml_mli ;
+  "-no-module-constraint-filter", Arg.Clear Odoc_global.filter_with_module_constraints,
   M.no_filter_with_module_constraints ;
 
-  "-keep-code", Arg.Set keep_code, M.keep_code^"\n" ;
+  "-keep-code", Arg.Set Odoc_global.keep_code, M.keep_code^"\n" ;
 
-  "-dump", Arg.String (fun s -> dump := Some s), M.dump ;
-  "-load", Arg.String (fun s -> load := !load @ [s]), M.load^"\n" ;
+  "-dump", Arg.String (fun s -> Odoc_global.dump := Some s), M.dump ;
+  "-load", Arg.String (fun s -> Odoc_global.load := !Odoc_global.load @ [s]), M.load^"\n" ;
 
-  "-t", Arg.String (fun s -> title := Some s), M.option_title ;
-  "-intro", Arg.String (fun s -> intro_file := Some s), M.option_intro ;
+  "-t", Arg.String (fun s -> Odoc_global.title := Some s), M.option_title ;
+  "-intro", Arg.String (fun s -> Odoc_global.intro_file := Some s), M.option_intro ;
   "-hide", Arg.String add_hidden_modules, M.hide_modules ;
-  "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)),
+  "-m", Arg.String (fun s -> Odoc_global.merge_options := !Odoc_global.merge_options @ (analyse_merge_options s)),
   M.merge_options ^
   "\n\n *** choosing a generator ***\n";
 
 (* generators *)
-  "-html", Arg.Unit (fun () -> set_doc_generator !default_html_generator), M.generate_html ;
-  "-latex", Arg.Unit (fun () -> set_doc_generator !default_latex_generator), M.generate_latex ;
-  "-texi", Arg.Unit (fun () -> set_doc_generator !default_texi_generator), M.generate_texinfo ;
-  "-man", Arg.Unit (fun () -> set_doc_generator !default_man_generator), M.generate_man ;
-  "-dot", Arg.Unit (fun () -> set_doc_generator !default_dot_generator), M.generate_dot ;
+  "-html", Arg.Unit (fun () -> set_generator
+       (Odoc_gen.Html (module Odoc_html.Generator : Odoc_html.Html_generator))),
+    M.generate_html ;
+  "-latex", Arg.Unit (fun () -> set_generator
+       (Odoc_gen.Latex (module Odoc_latex.Generator : Odoc_latex.Latex_generator))),
+    M.generate_latex ;
+  "-texi", Arg.Unit (fun () -> set_generator
+       (Odoc_gen.Texi (module Odoc_texi.Generator : Odoc_texi.Texi_generator))),
+    M.generate_texinfo ;
+  "-man", Arg.Unit (fun () -> set_generator
+       (Odoc_gen.Man (module Odoc_man.Generator : Odoc_man.Man_generator))),
+    M.generate_man ;
+  "-dot", Arg.Unit (fun () -> set_generator
+       (Odoc_gen.Dot (module Odoc_dot.Generator : Odoc_dot.Dot_generator))),
+    M.generate_dot ;
   "-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0),
   M.display_custom_generators_dir ;
   "-i", Arg.String (fun s -> ()), M.add_load_dir ;
@@ -262,51 +242,59 @@ let default_options = [
   "\n\n *** HTML options ***\n";
 
 (* html only options *)
-  "-all-params", Arg.Set with_parameter_list, M.with_parameter_list ;
-  "-css-style", Arg.String (fun s -> css_style := Some s), M.css_style ;
-  "-index-only", Arg.Set index_only, M.index_only ;
-  "-colorize-code", Arg.Set colorize_code, M.colorize_code ;
-  "-short-functors", Arg.Set html_short_functors, M.html_short_functors ;
-  "-charset", Arg.Set_string charset, (M.charset !charset)^
+  "-all-params", Arg.Set Odoc_html.with_parameter_list, M.with_parameter_list ;
+  "-css-style", Arg.String (fun s -> Odoc_html.css_style := Some s), M.css_style ;
+  "-index-only", Arg.Set Odoc_html.index_only, M.index_only ;
+  "-colorize-code", Arg.Set Odoc_html.colorize_code, M.colorize_code ;
+  "-short-functors", Arg.Set Odoc_html.html_short_functors, M.html_short_functors ;
+  "-charset", Arg.Set_string Odoc_html.charset, (M.charset !Odoc_html.charset)^
   "\n\n *** LaTeX options ***\n";
 
 (* latex only options *)
-  "-noheader", Arg.Unit (fun () -> with_header := false), M.no_header ;
-  "-notrailer", Arg.Unit (fun () -> with_trailer := false), M.no_trailer ;
-  "-sepfiles", Arg.Set separate_files, M.separate_files ;
-  "-latextitle", Arg.String f_latex_title, M.latex_title latex_titles ;
-  "-latex-value-prefix", Arg.String (fun s -> latex_value_prefix := s), M.latex_value_prefix ;
-  "-latex-type-prefix", Arg.String (fun s -> latex_type_prefix := s), M.latex_type_prefix ;
-  "-latex-exception-prefix", Arg.String (fun s -> latex_exception_prefix := s), M.latex_exception_prefix ;
-  "-latex-attribute-prefix", Arg.String (fun s -> latex_attribute_prefix := s), M.latex_attribute_prefix ;
-  "-latex-method-prefix", Arg.String (fun s -> latex_method_prefix := s), M.latex_method_prefix ;
-  "-latex-module-prefix", Arg.String (fun s -> latex_module_prefix := s), M.latex_module_prefix ;
-  "-latex-module-type-prefix", Arg.String (fun s -> latex_module_type_prefix := s), M.latex_module_type_prefix ;
-  "-latex-class-prefix", Arg.String (fun s -> latex_class_prefix := s), M.latex_class_prefix ;
-  "-latex-class-type-prefix", Arg.String (fun s -> latex_class_type_prefix := s), M.latex_class_type_prefix ;
-  "-notoc", Arg.Unit (fun () -> with_toc := false),
-  M.no_toc ^
+  "-noheader", Arg.Unit (fun () -> Odoc_global.with_header := false), M.no_header ;
+  "-notrailer", Arg.Unit (fun () -> Odoc_global.with_trailer := false), M.no_trailer ;
+  "-sepfiles", Arg.Set Odoc_latex.separate_files, M.separate_files ;
+  "-latextitle", Arg.String f_latex_title, M.latex_title Odoc_latex.latex_titles ;
+  "-latex-value-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_value_prefix := s), M.latex_value_prefix ;
+  "-latex-type-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_type_prefix := s), M.latex_type_prefix ;
+  "-latex-exception-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_exception_prefix := s), M.latex_exception_prefix ;
+  "-latex-attribute-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_attribute_prefix := s), M.latex_attribute_prefix ;
+  "-latex-method-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_method_prefix := s), M.latex_method_prefix ;
+  "-latex-module-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_module_prefix := s), M.latex_module_prefix ;
+  "-latex-module-type-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_module_type_prefix := s), M.latex_module_type_prefix ;
+  "-latex-class-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_class_prefix := s), M.latex_class_prefix ;
+  "-latex-class-type-prefix",
+    Arg.String (fun s -> Odoc_latex.latex_class_type_prefix := s), M.latex_class_type_prefix ;
+  "-notoc", Arg.Unit (fun () -> Odoc_global.with_toc := false), M.no_toc ^
   "\n\n *** texinfo options ***\n";
 
-(* tex only options *)
-  "-noindex", Arg.Clear with_index, M.no_index ;
-  "-esc8", Arg.Set esc_8bits, M.esc_8bits ;
-  "-info-section", Arg.String ((:=) info_section), M.info_section ;
-  "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]),
+(* texi only options *)
+  "-noindex", Arg.Clear Odoc_global.with_index, M.no_index ;
+  "-esc8", Arg.Set Odoc_texi.esc_8bits, M.esc_8bits ;
+  "-info-section", Arg.String ((:=) Odoc_texi.info_section), M.info_section ;
+  "-info-entry", Arg.String (fun s -> Odoc_texi.info_entry := !Odoc_texi.info_entry @ [ s ]),
   M.info_entry ^
   "\n\n *** dot options ***\n";
 
 (* dot only options *)
-  "-dot-colors", Arg.String (fun s -> dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ;
-  "-dot-include-all", Arg.Set dot_include_all, M.dot_include_all ;
-  "-dot-types", Arg.Set dot_types, M.dot_types ;
-  "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce^
+  "-dot-colors", Arg.String (fun s -> Odoc_dot.dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ;
+  "-dot-include-all", Arg.Set Odoc_dot.dot_include_all, M.dot_include_all ;
+  "-dot-types", Arg.Set Odoc_dot.dot_types, M.dot_types ;
+  "-dot-reduce", Arg.Set Odoc_dot.dot_reduce, M.dot_reduce^
   "\n\n *** man pages options ***\n";
 
 (* man only options *)
-  "-man-mini", Arg.Set man_mini, M.man_mini ;
-  "-man-suffix", Arg.String (fun s -> man_suffix := s), M.man_suffix ;
-  "-man-section", Arg.String (fun s -> man_section := s), M.man_section ;
+  "-man-mini", Arg.Set Odoc_man.man_mini, M.man_mini ;
+  "-man-suffix", Arg.String (fun s -> Odoc_man.man_suffix := s), M.man_suffix ;
+  "-man-section", Arg.String (fun s -> Odoc_man.man_section := s), M.man_section ;
 
 ]
 
@@ -327,7 +315,7 @@ let help_action () =
   let msg =
     Arg.usage_string
       (!options @ !help_options)
-      (M.usage ^ M.options_are) in 
+      (M.usage ^ M.options_are) in
   print_string msg
 let () =
   help_options := [
@@ -349,27 +337,22 @@ let add_option o =
   in
   options := iter !options
 
-let parse ~html_generator ~latex_generator ~texi_generator ~man_generator ~dot_generator =
+let parse () =
   let anonymous f =
     let sf =
       if Filename.check_suffix f "ml" then
-        Impl_file f
+        Odoc_global.Impl_file f
       else
         if Filename.check_suffix f "mli" then
-          Intf_file f
+          Odoc_global.Intf_file f
         else
           if Filename.check_suffix f "txt" then
-            Text_file f
+            Odoc_global.Text_file f
           else
             failwith (Odoc_messages.unknown_extension f)
     in
-    files := !files @ [sf]
+    Odoc_global.files := !Odoc_global.files @ [sf]
   in
-  default_html_generator := Some html_generator ;
-  default_latex_generator := Some latex_generator ;
-  default_texi_generator := Some texi_generator ;
-  default_man_generator := Some man_generator ;
-  default_dot_generator := Some dot_generator ;
   if modified_options () then append_last_doc "\n";
   let options = !options @ !help_options in
   let _ = Arg.parse options
@@ -379,4 +362,5 @@ let parse ~html_generator ~latex_generator ~texi_generator ~man_generator ~dot_g
   (* we sort the hidden modules by name, to be sure that for example,
      A.B is before A, so we will match against A.B before A in
      Odoc_name.hide_modules.*)
-  hidden_modules := List.sort (fun a -> fun b -> - (compare a b)) !hidden_modules
+  Odoc_global.hidden_modules :=
+    List.sort (fun a -> fun b -> - (compare a b)) !Odoc_global.hidden_modules

diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli
index b2c8cd0042e1750939279ecd166a1578e20db307..1d55de747775022c3ff03641a5ac09acbacb9134 100644 (file)
--- a/ocamldoc/odoc_args.mli
+++ b/ocamldoc/odoc_args.mli
@@ -13,183 +13,39 @@
 
 (** Analysis of the command line arguments. *)
 
-(** The kind of source file in arguments. *)
-type source_file =
-    Impl_file of string
-  | Intf_file of string
-  | Text_file of string
+(** The current module defining the generator to use. *)
+val current_generator : Odoc_gen.generator option ref
 
-(** The include_dirs in the OCaml compiler. *)
-val include_dirs : string list ref
-
-(** The class type of documentation generators. *)
-class type doc_generator =
-  object method generate : Odoc_module.t_module list -> unit end
-
-(** The function to be used to create a generator. *)
-val doc_generator : doc_generator option ref
-
-(** The merge options to be used. *)
-val merge_options : Odoc_types.merge_option list ref
-
-(** Classic mode or not. *)
-val classic : bool ref
-
-(** The file used by the generators outputting only one file. *)
-val out_file : string ref
-
-(** The optional file name to dump the collected information into.*)
-val dump : string option ref
-
-(** The list of information files to load. *)
-val load : string list ref
-
-(** Verbose mode or not. *)
-val verbose : bool ref
-
-(** We must sort the list of top modules or not.*)
-val sort_modules : bool ref
-
-(** We must not stop at the stop special comments. Default is false (we stop).*)
-val no_stop : bool ref
-
-(** We must raise an exception when we find an unknown @-tag. *)
-val no_custom_tags : bool ref
-
-(** We must remove the the first characters of each comment line, until the first asterisk '*'. *)
-val remove_stars : bool ref
-
-(** To keep the code while merging, when we have both .ml and .mli files for a module. *)
-val keep_code : bool ref
-
-(** To inverse implementation and interface files when merging. *)
-val inverse_merge_ml_mli : bool ref
-
-(** To filter module elements according to module type constraints. *)
-val filter_with_module_constraints : bool ref
-
-(** The optional title to use in the generated documentation. *)
-val title : string option ref
-
-(** The optional file whose content can be used as intro text. *)
-val intro_file : string option ref
-
-(** Flag to indicate whether we must display the complete list of parameters
-   for functions and methods. *)
-val with_parameter_list : bool ref
-
-(** The list of module names to hide. *)
-val hidden_modules : string list ref
-
-(** The directory where files have to be generated. *)
-val target_dir : string ref
-
-(** An optional file to use where a CSS style is defined (for HTML). *)
-val css_style : string option ref
-
-(** Generate only index files. (for HTML). *)
-val index_only : bool ref
-
-(** To colorize code in HTML generated documentation pages, not code pages. *)
-val colorize_code : bool ref
-
-(** To display functors in short form rather than with "functor ... -> ",
-   in HTML generated documentation. *)
-val html_short_functors : bool ref
-
-(** Encoding used in HTML pages header. *)
-val charset : string ref
-
-(** The flag which indicates if we must generate a header (for LaTeX). *)
-val with_header : bool ref
-
-(** The flag which indicates if we must generate a trailer (for LaTeX). *)
-val with_trailer : bool ref
-
-(** The flag to indicate if we must generate one file per module (for LaTeX). *)
-val separate_files : bool ref
-
-(** The list of pairs (title level, sectionning style). *)
-val latex_titles : (int * string) list ref
-
-(** The prefix to use for value labels in LaTeX. *)
-val latex_value_prefix : string ref
-
-(** The prefix to use for type labels in LaTeX. *)
-val latex_type_prefix : string ref
-
-(** The prefix to use for exception labels in LaTeX. *)
-val latex_exception_prefix : string ref
-
-(** The prefix to use for module labels in LaTeX. *)
-val latex_module_prefix : string ref
-
-(** The prefix to use for module type labels in LaTeX. *)
-val latex_module_type_prefix : string ref
-
-(** The prefix to use for class labels in LaTeX. *)
-val latex_class_prefix : string ref
-
-(** The prefix to use for class type labels in LaTeX. *)
-val latex_class_type_prefix : string ref
-
-(** The prefix to use for attribute labels in LaTeX. *)
-val latex_attribute_prefix : string ref
-
-(** The prefix to use for method labels in LaTeX. *)
-val latex_method_prefix : string ref
-
-(** The flag which indicates if we must generate a table of contents (for LaTeX). *)
-val with_toc : bool ref
-
-(** The flag which indicates if we must generate an index (for TeXinfo). *)
-val with_index : bool ref
-
-(** The flag which indicates if we must escape accentuated characters (for TeXinfo).*)
-val esc_8bits : bool ref
-
-(** The Info directory section *)
-val info_section : string ref
-
-(** The Info directory entries to insert *)
-val info_entry : string list ref
-
-(** Include all modules or only the ones on the command line, for the dot output. *)
-val dot_include_all : bool ref
-
-(** Generate dependency graph for types. *)
-val dot_types : bool ref
-
-(** Perform transitive reduction before dot output. *)
-val dot_reduce : bool ref
+(** To set the documentation generator. *)
+val set_generator : Odoc_gen.generator -> unit
 
-(** The colors used in the dot output. *)
-val dot_colors : string list ref
+(** Extend current HTML generator.
+  @raise Failure if another kind of generator is already set.*)
+val extend_html_generator : (module Odoc_gen.Html_functor) -> unit
 
-(** The suffix for man pages. *)
-val man_suffix : string ref
+(** Extend current LaTeX generator.
+  @raise Failure if another kind of generator is already set.*)
+val extend_latex_generator : (module Odoc_gen.Latex_functor) -> unit
 
-(** The section for man pages. *)
-val man_section : string ref
+(** Extend current Texi generator.
+  @raise Failure if another kind of generator is already set.*)
+val extend_texi_generator : (module Odoc_gen.Texi_functor) -> unit
 
-(** The flag to generate all man pages or only for modules and classes.*)
-val man_mini : bool ref
+(** Extend current man generator.
+  @raise Failure if another kind of generator is already set.*)
+val extend_man_generator : (module Odoc_gen.Man_functor) -> unit
 
-(** The files to be analysed. *)
-val files : source_file list ref
+(** Extend current dot generator.
+  @raise Failure if another kind of generator is already set.*)
+val extend_dot_generator : (module Odoc_gen.Dot_functor) -> unit
 
-(** To set the documentation generator. *)
-val set_doc_generator : doc_generator option -> unit
+(** Extend current base generator.
+  @raise Failure if another kind of generator is already set.*)
+val extend_base_generator : (module Odoc_gen.Base_functor) -> unit
 
 (** Add an option specification. *)
 val add_option : string * Arg.spec * string -> unit
 
 (** Parse the args.
    [byte] indicate if we are in bytecode mode (default is [true]).*)
-val parse :
-    html_generator:doc_generator ->
-      latex_generator:doc_generator ->
-        texi_generator:doc_generator ->
-          man_generator:doc_generator ->
-            dot_generator:doc_generator ->
-              unit
+val parse : unit -> unit

diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml
index 3456e14dea970b32c9c5064111785119cac37286..79db5e9535af53efc16ca05b50b848500b9c2c3c 100644 (file)
--- a/ocamldoc/odoc_ast.ml
+++ b/ocamldoc/odoc_ast.ml
@@ -357,6 +357,13 @@ module Analyser =
            let name_pre = Name.from_ident ident in
            let name = Name.parens_if_infix name_pre in
            let complete_name = Name.concat current_module_name name in
+           let code =
+              if !Odoc_global.keep_code then
+                Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+                      loc.Location.loc_end.Lexing.pos_cnum)
+              else
+                None
+            in
            (* create the value *)
            let new_value = {
              val_name = complete_name ;
@@ -364,7 +371,7 @@ module Analyser =
              val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
              val_recursive = rec_flag = Asttypes.Recursive ;
              val_parameters = tt_analyse_function_parameters env comment_opt pat_exp_list2 ;
-             val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
+             val_code = code ;
              val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
            }
            in
@@ -375,13 +382,20 @@ module Analyser =
            let name_pre = Name.from_ident ident in
            let name = Name.parens_if_infix name_pre in
            let complete_name = Name.concat current_module_name name in
+           let code =
+             if !Odoc_global.keep_code then
+                Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+                      loc.Location.loc_end.Lexing.pos_cnum)
+             else
+               None
+            in
            let new_value = {
              val_name = complete_name ;
              val_info = comment_opt ;
              val_type = Odoc_env.subst_type env pat.Typedtree.pat_type ;
              val_recursive = rec_flag = Asttypes.Recursive ;
              val_parameters = [] ;
-             val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
+             val_code = code ;
              val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
            }
            in
@@ -437,7 +451,7 @@ module Analyser =
            | l ->
                match l with
                  [] ->
-                   (* cas impossible, on l'a filtré avant *)
+                   (* cas impossible, on l'a filtré avant *)
                    assert false
                | (pattern_param, exp) :: second_ele :: q ->
                    (* implicit pattern matching -> anonymous parameter *)
@@ -543,111 +557,129 @@ module Analyser =
 
       | ((Parsetree.Pcf_val (label, mutable_flag, _, _, loc) |
           Parsetree.Pcf_valvirt (label, mutable_flag, _, loc) ) as x) :: q ->
-            let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in
-            let complete_name = Name.concat current_class_name label in
-            let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-            let type_exp =
+          let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in
+          let complete_name = Name.concat current_class_name label in
+          let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+          let type_exp =
             try
               if virt then
                 Typedtree_search.search_virtual_attribute_type table
-                  (Name.simple current_class_name) label
+                (Name.simple current_class_name) label
               else
                 Typedtree_search.search_attribute_type tt_cls label
             with Not_found ->
                 raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name))
-            in
-            let att =
-              {
-                att_value = { val_name = complete_name ;
-                              val_info = info_opt ;
-                              val_type = Odoc_env.subst_type env type_exp ;
-                              val_recursive = false ;
-                              val_parameters = [] ;
-                              val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-                              val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
-                            } ;
-                att_mutable = mutable_flag = Asttypes.Mutable ;
-                att_virtual = virt ;
-              }
-            in
-            iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q
+          in
+          let code =
+            if !Odoc_global.keep_code then
+              Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+                    loc.Location.loc_end.Lexing.pos_cnum)
+            else
+              None
+          in
+          let att =
+            {
+              att_value = { val_name = complete_name ;
+                val_info = info_opt ;
+                val_type = Odoc_env.subst_type env type_exp ;
+                val_recursive = false ;
+                val_parameters = [] ;
+                val_code = code ;
+                val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+              } ;
+              att_mutable = mutable_flag = Asttypes.Mutable ;
+              att_virtual = virt ;
+            }
+          in
+          iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q
 
         | (Parsetree.Pcf_virt  (label, private_flag, _, loc)) :: q ->
-            let complete_name = Name.concat current_class_name label in
-            let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-            let met_type =
-              try Odoc_sig.Signature_search.search_method_type label tt_class_sig
-              with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
-            in
-            let real_type =
+          let complete_name = Name.concat current_class_name label in
+          let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+          let met_type =
+            try Odoc_sig.Signature_search.search_method_type label tt_class_sig
+            with Not_found -> raise (Failure (Odoc_messages.method_type_not_found current_class_name label))
+          in
+          let real_type =
               match met_type.Types.desc with
-                Tarrow (_, _, t, _) ->
-                  t
-              |  _ ->
+              Tarrow (_, _, t, _) ->
+                t
+            |  _ ->
                 (* ?!? : not an arrow type ! return the original type *)
-                  met_type
-            in
-            let met =
-              {
-                met_value = { val_name = complete_name ;
-                              val_info = info_opt ;
-                              val_type = Odoc_env.subst_type env real_type ;
-                              val_recursive = false ;
-                              val_parameters = [] ;
-                              val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-                              val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
-                            } ;
-                met_private = private_flag = Asttypes.Private ;
-                met_virtual = true ;
-              }
-            in
-            (* update the parameter description *)
-            Odoc_value.update_value_parameters_text met.met_value;
+                met_type
+          in
+          let code =
+            if !Odoc_global.keep_code then
+              Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+               loc.Location.loc_end.Lexing.pos_cnum)
+            else
+              None
+          in
+          let met =
+            {
+              met_value = {
+                val_name = complete_name ;
+                val_info = info_opt ;
+                val_type = Odoc_env.subst_type env real_type ;
+                val_recursive = false ;
+                val_parameters = [] ;
+                val_code = code ;
+                val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+              } ;
+              met_private = private_flag = Asttypes.Private ;
+              met_virtual = true ;
+            }
+          in
+          (* update the parameter description *)
+          Odoc_value.update_value_parameters_text met.met_value;
 
-            iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
+          iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
 
         | (Parsetree.Pcf_meth  (label, private_flag, _, _, loc)) :: q ->
-            let complete_name = Name.concat current_class_name label in
-            let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-            let exp =
+          let complete_name = Name.concat current_class_name label in
+          let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
+          let exp =
               try Typedtree_search.search_method_expression tt_cls label
-              with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
-            in
-            let real_type =
-              match exp.exp_type.desc with
-                Tarrow (_, _, t,_) ->
-                  t
-              |  _ ->
+            with Not_found -> raise (Failure (Odoc_messages.method_not_found_in_typedtree complete_name))
+          in
+          let real_type =
+            match exp.exp_type.desc with
+              Tarrow (_, _, t,_) ->
+                t
+            |  _ ->
                 (* ?!? : not an arrow type ! return the original type *)
-                  exp.Typedtree.exp_type
-            in
-            let met =
-              {
-                met_value = { val_name = complete_name ;
-                              val_info = info_opt ;
-                              val_type = Odoc_env.subst_type env real_type ;
-                              val_recursive = false ;
-                              val_parameters = tt_analyse_method_expression env complete_name info_opt exp ;
-                              val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-                              val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
-                            } ;
-                met_private = private_flag = Asttypes.Private ;
-                met_virtual = false ;
+                exp.Typedtree.exp_type
+          in
+          let code =
+            if !Odoc_global.keep_code then
+                Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+               loc.Location.loc_end.Lexing.pos_cnum)
+            else
+              None
+          in
+          let met =
+            {
+              met_value = { val_name = complete_name ;
+                val_info = info_opt ;
+                val_type = Odoc_env.subst_type env real_type ;
+                val_recursive = false ;
+                val_parameters = tt_analyse_method_expression env complete_name info_opt exp ;
+                val_code = code ;
+                val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+              } ;
+              met_private = private_flag = Asttypes.Private ;
+              met_virtual = false ;
               }
-            in
-            (* update the parameter description *)
-            Odoc_value.update_value_parameters_text met.met_value;
+          in
+          (* update the parameter description *)
+          Odoc_value.update_value_parameters_text met.met_value;
 
-            iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
+          iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q
 
         | Parsetree.Pcf_cstr (_, _, loc) :: q ->
             (* don't give a $*%@ ! *)
             iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q
 
-        | Parsetree.Pcf_let (_, _, loc) :: q ->
-            (* don't give a $*%@ ! *)
-            iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q
-
         | (Parsetree.Pcf_init exp) :: q ->
             iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q
       in
@@ -662,10 +694,10 @@ module Analyser =
               Typedtree.Tclass_ident p -> Name.from_path p
             | _ ->
                 (* we try to get the name from the environment. *)
-                (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
+                (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
                 Name.from_longident lid
           in
-          (* On n'a pas ici les paramètres de type sous forme de Types.type_expr,
+          (* On n'a pas ici les paramètres de type sous forme de Types.type_expr,
              par contre on peut les trouver dans le class_type *)
           let params =
             match tt_class_exp.Typedtree.cl_type with
@@ -750,7 +782,7 @@ module Analyser =
             match tt_class_expr2.Typedtree.cl_desc with
               Typedtree.Tclass_ident p -> Name.from_path p (* A VOIR : obtenir le nom complet *)
             | _ ->
-                (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
+                (* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( même quand on a class tutu = toto *)
                 match p_class_expr2.Parsetree.pcl_desc with
                   Parsetree.Pcl_constr (lid, _) ->
                     (* we try to get the name from the environment. *)
@@ -942,7 +974,7 @@ module Analyser =
         | Element_type t ->
              (function
                 Types.Tsig_type (ident,_,_) ->
-                  (* A VOIR: il est possible que le détail du type soit caché *)
+                  (* A VOIR: il est possible que le détail du type soit caché *)
                   let n1 = Name.simple t.ty_name
                   and n2 = Ident.name ident in
                   n1 = n2
@@ -1090,108 +1122,115 @@ module Analyser =
           (0, new_env, l_ele)
 
       | Parsetree.Pstr_primitive (name_pre, val_desc) ->
-          (* of string * value_description *)
-          print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]");
-          let typ = Typedtree_search.search_primitive table name_pre in
-          let name = Name.parens_if_infix name_pre in
-          let complete_name = Name.concat current_module_name name in
-          let new_value = {
-             val_name = complete_name ;
-             val_info = comment_opt ;
-             val_type = Odoc_env.subst_type env typ ;
-             val_recursive = false ;
-             val_parameters = [] ;
-             val_code = Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum loc.Location.loc_end.Lexing.pos_cnum) ;
-             val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
-           }
-           in
-          let new_env = Odoc_env.add_value env new_value.val_name in
-          (0, new_env, [Element_value new_value])
+            (* of string * value_description *)
+            print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]");
+            let typ = Typedtree_search.search_primitive table name_pre in
+            let name = Name.parens_if_infix name_pre in
+            let complete_name = Name.concat current_module_name name in
+            let code =
+              if !Odoc_global.keep_code then
+                Some (get_string_of_file loc.Location.loc_start.Lexing.pos_cnum
+                      loc.Location.loc_end.Lexing.pos_cnum)
+              else
+                None
+            in
+            let new_value = {
+                val_name = complete_name ;
+                val_info = comment_opt ;
+                val_type = Odoc_env.subst_type env typ ;
+                val_recursive = false ;
+                val_parameters = [] ;
+                val_code = code ;
+                val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
+              }
+            in
+            let new_env = Odoc_env.add_value env new_value.val_name in
+            (0, new_env, [Element_value new_value])
 
-      | Parsetree.Pstr_type name_typedecl_list ->
-          (* of (string * type_declaration) list *)
-          (* we start by extending the environment *)
-          let new_env =
-            List.fold_left
+        | Parsetree.Pstr_type name_typedecl_list ->
+            (* of (string * type_declaration) list *)
+            (* we start by extending the environment *)
+            let new_env =
+              List.fold_left
               (fun acc_env -> fun (name, _) ->
-                let complete_name = Name.concat current_module_name name in
-                Odoc_env.add_type acc_env complete_name
+                 let complete_name = Name.concat current_module_name name in
+                 Odoc_env.add_type acc_env complete_name
               )
               env
               name_typedecl_list
-          in
-          let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list =
-            match name_type_decl_list with
-              [] -> (maybe_more_acc, [])
-            | (name, type_decl) :: q ->
-                let complete_name = Name.concat current_module_name name in
-                let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
-                let loc_end =  type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum in
-                let pos_limit2 =
+            in
+            let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list =
+              match name_type_decl_list with
+                [] -> (maybe_more_acc, [])
+              | (name, type_decl) :: q ->
+                  let complete_name = Name.concat current_module_name name in
+                  let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in
+                  let loc_end =  type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum in
+                  let pos_limit2 =
                   match q with
-                    [] -> pos_limit
-                  | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
-                in
-                let (maybe_more, name_comment_list) =
+                      [] -> pos_limit
+                    | (_, td) :: _ -> td.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum
+                  in
+                  let (maybe_more, name_comment_list) =
                     Sig.name_comment_from_type_kind
-                      loc_end
-                      pos_limit2
-                      type_decl.Parsetree.ptype_kind
-                in
-                let tt_type_decl =
-                  try Typedtree_search.search_type_declaration table name
-                  with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name))
-                in
-                let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)
-                  if first then
-                    (comment_opt , [])
-                  else
-                    get_comments_in_module last_pos loc_start
-                in
-                let kind = Sig.get_type_kind
+                    loc_end
+                    pos_limit2
+                    type_decl.Parsetree.ptype_kind
+                  in
+                  let tt_type_decl =
+                    try Typedtree_search.search_type_declaration table name
+                    with Not_found -> raise (Failure (Odoc_messages.type_not_found_in_typedtree complete_name))
+                  in
+                  let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)
+                    if first then
+                      (comment_opt , [])
+                    else
+                      get_comments_in_module last_pos loc_start
+                  in
+                  let kind = Sig.get_type_kind
                     new_env name_comment_list
                     tt_type_decl.Types.type_kind
-                in
-                let new_end = loc_end + maybe_more in
-                let t =
-                  {
-                    ty_name = complete_name ;
-                    ty_info = com_opt ;
-                    ty_parameters =
+                  in
+                  let new_end = loc_end + maybe_more in
+                  let t =
+                    {
+                      ty_name = complete_name ;
+                      ty_info = com_opt ;
+                      ty_parameters =
                       List.map2
-                        (fun p (co,cn,_) ->
-                          (Odoc_env.subst_type new_env p,
-                           co, cn)
-                        )
+                      (fun p (co,cn,_) ->
+                         (Odoc_env.subst_type new_env p,
+                          co, cn)
+                      )
                       tt_type_decl.Types.type_params
                       tt_type_decl.Types.type_variance ;
-                    ty_kind = kind ;
-                    ty_private = tt_type_decl.Types.type_private;
-                    ty_manifest =
-                    (match tt_type_decl.Types.type_manifest with
-                      None -> None
-                    | Some t -> Some (Odoc_env.subst_type new_env t));
-                    ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ;
-                    ty_code =
+                      ty_kind = kind ;
+                      ty_private = tt_type_decl.Types.type_private;
+                      ty_manifest =
+                      (match tt_type_decl.Types.type_manifest with
+                         None -> None
+                       | Some t -> Some (Odoc_env.subst_type new_env t));
+                      ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ;
+                      ty_code =
                       (
-                       if !Odoc_args.keep_code then
+                       if !Odoc_global.keep_code then
                          Some (get_string_of_file loc_start new_end)
                        else
                          None
                       ) ;
-                  }
-                in
-                let (maybe_more2, info_after_opt) =
-                  My_ir.just_after_special
+                    }
+                  in
+                  let (maybe_more2, info_after_opt) =
+                    My_ir.just_after_special
                     !file_name
                     (get_string_of_file new_end pos_limit2)
-                in
-                t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ;
-                let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in
-                (maybe_more3, ele_comments @ ((Element_type t) :: eles))
-          in
-          let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in
-          (maybe_more, new_env, eles)
+                  in
+                  t.ty_info <- Sig.merge_infos t.ty_info info_after_opt ;
+                  let (maybe_more3, eles) = f (maybe_more + maybe_more2) (new_end + maybe_more2) q in
+                  (maybe_more3, ele_comments @ ((Element_type t) :: eles))
+            in
+            let (maybe_more, eles) = f ~first: true 0 loc.Location.loc_start.Lexing.pos_cnum name_typedecl_list in
+            (maybe_more, new_env, eles)
 
       | Parsetree.Pstr_exception (name, excep_decl) ->
           (* a new exception is defined *)
@@ -1209,12 +1248,12 @@ module Analyser =
             {
               ex_name = complete_name ;
               ex_info = comment_opt ;
-              ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl ;
+              ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl.exn_args ;
               ex_alias = None ;
               ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;
               ex_code =
                 (
-                 if !Odoc_args.keep_code then
+                 if !Odoc_global.keep_code then
                    Some (get_string_of_file loc_start loc_end)
                  else
                    None
@@ -1260,7 +1299,7 @@ module Analyser =
                  tt_module_expr
              in
              let code =
-               if !Odoc_args.keep_code then
+               if !Odoc_global.keep_code then
                  let loc = module_expr.Parsetree.pmod_loc in
                  let st = loc.Location.loc_start.Lexing.pos_cnum in
                  let en = loc.Location.loc_end.Lexing.pos_cnum in
@@ -1274,7 +1313,7 @@ module Analyser =
              let new_env = Odoc_env.add_module env new_module.m_name in
              let new_env2 =
                match new_module.m_type with
-                 (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
+                 (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
                  Types.Tmty_signature s ->
                    Odoc_env.add_signature new_env new_module.m_name
                      ~rel: (Name.simple new_module.m_name) s
@@ -1373,7 +1412,7 @@ module Analyser =
           let new_env = Odoc_env.add_module_type env mt.mt_name in
           let new_env2 =
             match tt_module_type with
-              (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on n'aurait pas la signature *)
+              (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on n'aurait pas la signature *)
               Types.Tmty_signature s ->
                 Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
             | _ ->
@@ -1501,7 +1540,7 @@ module Analyser =
               im_info = comment_opt ;
             }
           in
-          (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
+          (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
 
      (** Analysis of a [Parsetree.module_expr] and a name to return a [t_module].*)
      and analyse_module env current_module_name module_name comment_opt p_module_expr tt_module_expr =
@@ -1622,7 +1661,7 @@ module Analyser =
               p_modtype tt_modtype
           in
           let tt_modtype = Odoc_env.subst_module_type env tt_modtype in
-          if !Odoc_args.filter_with_module_constraints then
+          if !Odoc_global.filter_with_module_constraints then
             filter_module_with_module_type_constraint m_base2 tt_modtype;
           {
             m_base with
@@ -1647,7 +1686,7 @@ module Analyser =
             m_kind = Module_struct elements2 ;
           }
 
-      | (Parsetree.Pmod_unpack (p_exp, pkg_type),
+      | (Parsetree.Pmod_unpack (p_exp),
          Typedtree.Tmod_unpack (t_exp, tt_modtype)) ->
           print_DEBUG ("Odoc_ast: case Parsetree.Pmod_unpack + Typedtree.Tmod_unpack "^module_name);
           let code =
@@ -1658,7 +1697,13 @@ module Analyser =
             let s = get_string_of_file exp_loc_end loc_end in
             Printf.sprintf "(val ...%s" s
           in
-          let name = Odoc_env.full_module_type_name env (Name.from_longident (fst pkg_type)) in
+          (* let name = Odoc_env.full_module_type_name env (Name.from_path (fst pkg_type)) in *)
+          let name =
+            match tt_modtype with
+            | Tmty_ident p ->
+                Odoc_env.full_module_type_name env (Name.from_path p)
+            | _ -> ""
+          in
           let alias = { mta_name = name ; mta_module = None } in
           { m_base with
             m_type = Odoc_env.subst_module_type env tt_modtype ;
@@ -1725,7 +1770,7 @@ module Analyser =
          m_kind = kind ;
          m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ;
          m_top_deps = [] ;
-         m_code = (if !Odoc_args.keep_code then Some !file else None) ;
+         m_code = (if !Odoc_global.keep_code then Some !file else None) ;
          m_code_intf = None ;
          m_text_only = false ;
        }

diff --git a/ocamldoc/odoc_class.ml b/ocamldoc/odoc_class.ml
index 676d0ebc374fe227f13eb0479692ffba2b28be98..28abf67031aa4a4311f568677c97913029ca6b4f 100644 (file)
--- a/ocamldoc/odoc_class.ml
+++ b/ocamldoc/odoc_class.ml
@@ -115,7 +115,7 @@ let rec class_elements ?(trans=true) cl =
     | Class_constraint (c_kind, ct_kind) ->
         iter_kind c_kind
       (* A VOIR : utiliser le c_kind ou le ct_kind ?
-         Pour l'instant, comme le ct_kind n'est pas analysé,
+         Pour l'instant, comme le ct_kind n'est pas analysé,
          on cherche dans le c_kind
          class_type_elements ~trans: trans
          { clt_name = "" ; clt_info = None ;

diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml
index ea5427e077f643080e9a8cc7bf7bbd8b1667cc95..af524eefaf945f54ff63d6b545a26b5e66105ac1 100644 (file)
--- a/ocamldoc/odoc_comments.ml
+++ b/ocamldoc/odoc_comments.ml
@@ -38,7 +38,7 @@ module Info_retriever =
       | Odoc_text.Text_syntax (l, c, s) ->
           raise (Failure (Odoc_messages.text_parse_error l c s))
       | _ ->
-          raise (Failure ("Erreur inconnue lors du parse de see : "^s))
+          raise (Failure ("Unknown error while parsing @see tag: "^s))
 
     let retrieve_info fun_lex file (s : string) =
       try

diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml
index 962da359ebc3e3328acbfbf05534b6d1a251754c..cd79790d24afb24c88744e792e808218b2ff22eb 100644 (file)
--- a/ocamldoc/odoc_cross.ml
+++ b/ocamldoc/odoc_cross.ml
@@ -58,7 +58,9 @@ module P_alias =
     let p_class c _ = (false, false)
     let p_class_type ct _ = (false, false)
     let p_value v _ = false
-    let p_type t _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type t _ = (false, false)
     let p_exception e _ = e.ex_alias <> None
     let p_attribute a _ = false
     let p_method m _ = false
@@ -178,7 +180,7 @@ let kind_name_exists kind =
     match kind with
       RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false)
     | RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false)
-    | RK_class -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false)
+    | RK_class -> (fun e -> match e with Odoc_search.Res_class _ -> true | _ -> false)
     | RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false)
     | RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false)
     | RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false)
@@ -186,6 +188,8 @@ let kind_name_exists kind =
     | RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false)
     | RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false)
     | RK_section _ -> assert false
+    | RK_recfield -> (fun e -> match e with Odoc_search.Res_recfield _ -> true | _ -> false)
+    | RK_const -> (fun e -> match e with Odoc_search.Res_const _ -> true | _ -> false)
   in
   fun name ->
     try List.exists pred (get_known_elements name)
@@ -200,6 +204,8 @@ let type_exists = kind_name_exists RK_type
 let exception_exists = kind_name_exists RK_exception
 let attribute_exists = kind_name_exists RK_attribute
 let method_exists = kind_name_exists RK_method
+let recfield_exists = kind_name_exists RK_recfield
+let const_exists = kind_name_exists RK_const
 
 let lookup_module name =
   match List.find
@@ -246,8 +252,17 @@ class scan =
     inherit Odoc_scan.scanner
     method! scan_value v =
       add_known_element v.val_name (Odoc_search.Res_value v)
-    method! scan_type t =
-      add_known_element t.ty_name (Odoc_search.Res_type t)
+    method! scan_type_recfield t f =
+      add_known_element
+        (Printf.sprintf "%s.%s" t.ty_name f.rf_name)
+        (Odoc_search.Res_recfield (t, f))
+    method! scan_type_const t f =
+      add_known_element
+        (Printf.sprintf "%s.%s" t.ty_name f.vc_name)
+        (Odoc_search.Res_const (t, f))
+    method! scan_type_pre t =
+      add_known_element t.ty_name (Odoc_search.Res_type t);
+      true
     method! scan_exception e =
       add_known_element e.ex_name (Odoc_search.Res_exception e)
     method! scan_attribute a =
@@ -620,6 +635,8 @@ let not_found_of_kind kind name =
   | RK_attribute -> Odoc_messages.cross_attribute_not_found
   | RK_method -> Odoc_messages.cross_method_not_found
   | RK_section _ -> Odoc_messages.cross_section_not_found
+  | RK_recfield -> Odoc_messages.cross_recfield_not_found
+  | RK_const -> Odoc_messages.cross_const_not_found
   ) name
 
 let rec assoc_comments_text_elements parent_name module_list t_ele =
@@ -675,6 +692,10 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
                  | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute)
                  | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method)
                  | Odoc_search.Res_section (_ ,t)-> assert false
+                 | Odoc_search.Res_recfield (t, f) ->
+                     (Printf.sprintf "%s.%s" t.ty_name f.rf_name, RK_recfield)
+                 | Odoc_search.Res_const (t, f) ->
+                     (Printf.sprintf "%s.%s" t.ty_name f.vc_name, RK_const)
                in
                add_verified (name, Some kind) ;
                (name, Some kind)
@@ -684,7 +705,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
          | (_, None) ->
              match parent_name with
                None ->
-                 Odoc_messages.pwarning (Odoc_messages.cross_element_not_found initial_name);
+                 Odoc_global.pwarning (Odoc_messages.cross_element_not_found initial_name);
                  Ref (initial_name, None, text_option)
              | Some p ->
                  let parent_name =
@@ -731,6 +752,8 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
                    | RK_attribute -> attribute_exists
                    | RK_method -> method_exists
                    | RK_section _ -> assert false
+                   | RK_recfield -> recfield_exists
+                   | RK_const -> const_exists
                  in
                  if f name then
                    (
@@ -745,7 +768,7 @@ let rec assoc_comments_text_elements parent_name module_list t_ele =
            | (_, None) ->
                match parent_name with
                  None ->
-                   Odoc_messages.pwarning (not_found_of_kind kind initial_name);
+                   Odoc_global.pwarning (not_found_of_kind kind initial_name);
                    Ref (initial_name, None, text_option)
                | Some p ->
                    let parent_name =
@@ -987,7 +1010,7 @@ let associate module_list =
    | l ->
        List.iter
          (fun nf ->
-           Odoc_messages.pwarning
+           Odoc_global.pwarning
              (
               match nf with
                 NF_m n -> Odoc_messages.cross_module_not_found n

diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml
index 86a0f247c9b45b75226aa98e0fa4b2b215f870a2..8878e723e07bb2d666535d20eb2d9ed21dcf493f 100644 (file)
--- a/ocamldoc/odoc_dep.ml
+++ b/ocamldoc/odoc_dep.ml
@@ -1,5 +1,5 @@
 (***********************************************************************)
-(*                               OCamldoc                              *)
+(*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
 (*                                                                     *)

diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml
index 452bf2bfa70676dd0e4c5cf514fb004d5f0212bf..a0d5ee2224e00231aac2cb0cd064a7f2ca8c0bae 100644 (file)
--- a/ocamldoc/odoc_dot.ml
+++ b/ocamldoc/odoc_dot.ml
@@ -1,5 +1,5 @@
 (***********************************************************************)
-(*                               Ocamldoc                              *)
+(*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
 (*                                                                     *)
@@ -18,6 +18,17 @@ open Odoc_info
 
 module F = Format
 
+let dot_include_all = ref false
+
+let dot_types = ref false
+
+let dot_reduce = ref false
+
+let dot_colors  = ref (List.flatten Odoc_messages.default_dot_colors)
+
+module Generator =
+struct
+
 (** This class generates a dot file showing the top modules dependencies. *)
 class dot =
   object (self)
@@ -29,7 +40,7 @@ class dot =
     val mutable modules = []
 
     (** Colors to use when finding new locations of modules. *)
-    val mutable colors = !Args.dot_colors
+    val mutable colors = !dot_colors
 
     (** Graph header. *)
     method header =
@@ -73,7 +84,7 @@ class dot =
     method generate_for_module fmt m =
       let l = List.filter
           (fun n ->
-            !Args.dot_include_all or
+            !dot_include_all or
             (List.exists (fun m -> m.Module.m_name = n) modules))
           m.Module.m_top_deps
       in
@@ -88,11 +99,11 @@ class dot =
 
     method generate_types types =
       try
-        let oc = open_out !Args.out_file in
+        let oc = open_out !Global.out_file in
         let fmt = F.formatter_of_out_channel oc in
         F.fprintf fmt "%s" self#header;
         let graph = Odoc_info.Dep.deps_of_types
-            ~kernel: !Args.dot_reduce
+            ~kernel: !dot_reduce
             types
         in
         List.iter (self#generate_for_type fmt) graph;
@@ -106,11 +117,11 @@ class dot =
     method generate_modules modules_list =
       try
         modules <- modules_list ;
-        let oc = open_out !Args.out_file in
+        let oc = open_out !Global.out_file in
         let fmt = F.formatter_of_out_channel oc in
         F.fprintf fmt "%s" self#header;
 
-        if !Args.dot_reduce then
+        if !dot_reduce then
           Odoc_info.Dep.kernel_deps_of_modules modules_list;
 
         List.iter (self#generate_for_module fmt) modules_list;
@@ -123,9 +134,13 @@ class dot =
 
     (** Generate the dot code in the file {!Odoc_info.Args.out_file}. *)
     method generate (modules_list : Odoc_info.Module.t_module list) =
-      colors <- !Args.dot_colors;
-      if !Args.dot_types then
+      colors <- !dot_colors;
+      if !dot_types then
         self#generate_types (Odoc_info.Search.types modules_list)
       else
         self#generate_modules modules_list
   end
+end
+
+module type Dot_generator = module type of Generator
+

diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml
index a108cf416a28bb1d13748bef52c128589c59213a..9a1c941d7121e1c34d0e9321ef5517ffce4d8363 100644 (file)
--- a/ocamldoc/odoc_env.ml
+++ b/ocamldoc/odoc_env.ml
@@ -56,7 +56,7 @@ let rec add_signature env root ?rel signat =
     | Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions }
     | Types.Tsig_module (ident, modtype, _) ->
         let env2 =
-          match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
+          match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
             Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s
           |  _ -> env
         in
@@ -68,7 +68,7 @@ let rec add_signature env root ?rel signat =
               env
           | Types.Tmodtype_manifest modtype ->
               match modtype with
-                 (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
+                 (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
                 Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s
               |  _ -> env
         in

diff --git a/ocamldoc/odoc_gen.ml b/ocamldoc/odoc_gen.ml
new file mode 100644 (file)
index 0000000..b1909e7
--- /dev/null
+++ b/ocamldoc/odoc_gen.ml
@@ -0,0 +1,60 @@
+(***********************************************************************)
+(*                             OCamldoc                                *)
+(*                                                                     *)
+(*            Maxence Guesdon, projet Gallium, INRIA Rocquencourt      *)
+(*                                                                     *)
+(*  Copyright 2010 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(** *)
+
+class type doc_generator =
+  object method generate : Odoc_module.t_module list -> unit end;;
+
+module type Base = sig
+    class generator : doc_generator
+  end;;
+
+module Base_generator : Base = struct
+  class generator : doc_generator = object method generate l = () end
+  end;;
+
+module type Base_functor = functor (G: Base) -> Base
+module type Html_functor = functor (G: Odoc_html.Html_generator) -> Odoc_html.Html_generator
+module type Latex_functor = functor (G: Odoc_latex.Latex_generator) -> Odoc_latex.Latex_generator
+module type Texi_functor = functor (G: Odoc_texi.Texi_generator) -> Odoc_texi.Texi_generator
+module type Man_functor = functor (G: Odoc_man.Man_generator) -> Odoc_man.Man_generator
+module type Dot_functor = functor (G: Odoc_dot.Dot_generator) -> Odoc_dot.Dot_generator
+
+type generator =
+  | Html of (module Odoc_html.Html_generator)
+  | Latex of (module Odoc_latex.Latex_generator)
+  | Texi of (module Odoc_texi.Texi_generator)
+  | Man of (module Odoc_man.Man_generator)
+  | Dot of (module Odoc_dot.Dot_generator)
+  | Base of (module Base)
+;;
+
+let get_minimal_generator = function
+  Html m ->
+    let module M = (val m : Odoc_html.Html_generator) in
+    (new M.html :> doc_generator)
+| Latex m ->
+    let module M = (val m : Odoc_latex.Latex_generator) in
+    (new M.latex :> doc_generator)
+| Man m ->
+    let module M = (val m : Odoc_man.Man_generator) in
+    (new M.man :> doc_generator)
+| Texi m ->
+    let module M = (val m : Odoc_texi.Texi_generator) in
+    (new M.texi :> doc_generator)
+| Dot m ->
+    let module M = (val m : Odoc_dot.Dot_generator) in
+    (new M.dot :> doc_generator)
+| Base m ->
+    let module M = (val m : Base) in
+    new M.generator
+    ;;

diff --git a/ocamldoc/odoc_gen.mli b/ocamldoc/odoc_gen.mli
new file mode 100644 (file)
index 0000000..37768c0
--- /dev/null
+++ b/ocamldoc/odoc_gen.mli
@@ -0,0 +1,42 @@
+(***********************************************************************)
+(*                             OCamldoc                                *)
+(*                                                                     *)
+(*            Maxence Guesdon, projet Gallium, INRIA Rocquencourt      *)
+(*                                                                     *)
+(*  Copyright 2010 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(** The types of generators. *)
+
+(** The minimal class type of documentation generators. *)
+class type doc_generator =
+  object method generate : Odoc_module.t_module list -> unit end;;
+
+(** The module type of minimal generators. *)
+module type Base = sig
+    class generator : doc_generator
+  end;;
+
+module Base_generator : Base
+
+module type Base_functor = functor (P: Base) -> Base
+module type Html_functor = functor (G: Odoc_html.Html_generator) -> Odoc_html.Html_generator
+module type Latex_functor = functor (G: Odoc_latex.Latex_generator) -> Odoc_latex.Latex_generator
+module type Texi_functor = functor (G: Odoc_texi.Texi_generator) -> Odoc_texi.Texi_generator
+module type Man_functor = functor (G: Odoc_man.Man_generator) -> Odoc_man.Man_generator
+module type Dot_functor = functor (G: Odoc_dot.Dot_generator) -> Odoc_dot.Dot_generator
+
+(** Various ways to create a generator. *)
+type generator =
+  | Html of (module Odoc_html.Html_generator)
+  | Latex of (module Odoc_latex.Latex_generator)
+  | Texi of (module Odoc_texi.Texi_generator)
+  | Man of (module Odoc_man.Man_generator)
+  | Dot of (module Odoc_dot.Dot_generator)
+  | Base of (module Base)
+;;
+
+val get_minimal_generator : generator -> doc_generator

diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml
index 4e0845661795e9b76907caf481a40c87ce03e8b1..b2d7bf872f41d4403cfa3247c59e7ea302f0df2a 100644 (file)
--- a/ocamldoc/odoc_global.ml
+++ b/ocamldoc/odoc_global.ml
@@ -1,5 +1,5 @@
 (***********************************************************************)
-(*                               OCamldoc                              *)
+(*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
 (*                                                                     *)
@@ -13,10 +13,77 @@
 
 (** Global variables. *)
 
+(* Tell ocaml compiler not to generate files. *)
+let _ = Clflags.dont_write_files := true
+
+open Clflags
+
+type source_file =
+    Impl_file of string
+  | Intf_file of string
+  | Text_file of string
+
+let include_dirs = Clflags.include_dirs
+
 let errors = ref 0
 
 let warn_error = ref false
 
+let pwarning s =
+  if !Odoc_config.print_warnings then prerr_endline (Odoc_messages.warning^": "^s);
+  if !warn_error then incr errors
+
+let merge_options = ref ([] : Odoc_types.merge_option list)
+
+let classic = Clflags.classic
+
+let dump = ref (None : string option)
+
+let load = ref ([] : string list)
+
+(** Allow arbitrary recursive types. *)
+let recursive_types = Clflags.recursive_types
+
+(** Optional preprocessor command. *)
+let preprocessor = Clflags.preprocessor
+
+let sort_modules = ref false
+
+let no_custom_tags = ref false
+
+let no_stop = ref false
+
+let remove_stars = ref false
+
+let keep_code = ref false
+
+let inverse_merge_ml_mli = ref false
+
+let filter_with_module_constraints = ref true
+
+let hidden_modules = ref ([] : string list)
+
+let files = ref []
+
+
+
+let out_file = ref Odoc_messages.default_out_file
+
+let verbose = ref false
+
+let target_dir = ref Filename.current_dir_name
+
+let title = ref (None : string option)
+
+let intro_file = ref (None : string option)
+
+let with_header = ref true
+
+let with_trailer = ref true
+
+let with_toc = ref true
+
+let with_index = ref true
+
+
 
-(* Tell ocaml compiler not to generate files. *)
-let _ = Clflags.dont_write_files := true

diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli
index 3a9eab6514e3af60194f34f091693a9a84d90988..d3d17ebe38e4b7a2a3424d7157a4a77c32b08069 100644 (file)
--- a/ocamldoc/odoc_global.mli
+++ b/ocamldoc/odoc_global.mli
@@ -1,5 +1,5 @@
 (***********************************************************************)
-(*                               Ocamldoc                              *)
+(*                             OCamldoc                                *)
 (*                                                                     *)
 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
 (*                                                                     *)
@@ -13,8 +13,92 @@
 
 (** Global variables. *)
 
+(** The kind of source file in arguments. *)
+type source_file =
+    Impl_file of string
+  | Intf_file of string
+  | Text_file of string
+
+(** The include_dirs in the OCaml compiler. *)
+val include_dirs : string list ref
+
+(** Optional preprocessor command to pass to ocaml compiler. *)
+val preprocessor : string option ref
+
+(** Recursive types flag to passe to ocaml compiler. *)
+val recursive_types : bool ref
+
+(** The merge options to be used. *)
+val merge_options : Odoc_types.merge_option list ref
+
+(** Classic mode or not. *)
+val classic : bool ref
+
+(** The optional file name to dump the collected information into.*)
+val dump : string option ref
+
+(** The list of information files to load. *)
+val load : string list ref
+
+(** We must sort the list of top modules or not.*)
+val sort_modules : bool ref
+
+(** We must not stop at the stop special comments. Default is false (we stop).*)
+val no_stop : bool ref
+
+(** We must raise an exception when we find an unknown @-tag. *)
+val no_custom_tags : bool ref
+
+(** We must remove the the first characters of each comment line, until the first asterisk '*'. *)
+val remove_stars : bool ref
+
+(** To keep the code while merging, when we have both .ml and .mli files for a module. *)
+val keep_code : bool ref
+
+(** To inverse implementation and interface files when merging. *)
+val inverse_merge_ml_mli : bool ref
+
+(** To filter module elements according to module type constraints. *)
+val filter_with_module_constraints : bool ref
+
+(** The list of module names to hide. *)
+val hidden_modules : string list ref
+
+(** The files to be analysed. *)
+val files : source_file list ref
 (** A counter for errors. *)
 val errors : int ref
 
 (** Indicate if a warning is an error. *)
 val warn_error : bool ref
+
+(** Print the given warning, adding it to the list of {!errors}
+if {!warn_error} is [true]. *)
+val pwarning : string -> unit
+
+(** The file used by the generators outputting only one file. *)
+val out_file : string ref
+
+(** Verbose mode or not. *)
+val verbose : bool ref
+
+(** The optional file whose content can be used as intro text. *)
+val intro_file : string option ref
+
+(** The optional title to use in the generated documentation. *)
+val title : string option ref
+
+(** The directory where files have to be generated. *)
+val target_dir : string ref
+
+(** The flag which indicates if we must generate a table of contents. *)
+val with_toc : bool ref
+
+(** The flag which indicates if we must generate an index. *)
+val with_index : bool ref
+
+(** The flag which indicates if we must generate a header.*)
+val with_header : bool ref
+
+(** The flag which indicates if we must generate a trailer.*)
+val with_trailer : bool ref

diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml
index 4da125c20f657d7f460f208740065e58f5ff4160..6f494284ffceda7583a6fcc9890bb4e3e457527c 100644 (file)
--- a/ocamldoc/odoc_html.ml
+++ b/ocamldoc/odoc_html.ml
@@ -23,6 +23,13 @@ open Exception
 open Class
 open Module
 
+let with_parameter_list = ref false
+let css_style = ref None
+let index_only = ref false
+let colorize_code = ref false
+let html_short_functors = ref false
+let charset = ref "iso-8859-1"
+
 
 (** The functions used for naming files and html marks.*)
 module Naming =
@@ -30,6 +37,9 @@ module Naming =
     (** The prefix for types marks. *)
     let mark_type = "TYPE"
 
+    (** The prefix for types elements (record fields or constructors). *)
+    let mark_type_elt = "TYPEELT"
+
     (** The prefix for functions marks. *)
     let mark_function = "FUN"
 
@@ -82,9 +92,25 @@ module Naming =
     (** Return the link target for the given type. *)
     let type_target t = target mark_type (Name.simple t.ty_name)
 
+    (** Return the link target for the given variant constructor. *)
+    let const_target t f =
+      let name = Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.vc_name in
+      target mark_type_elt name
+
+    (** Return the link target for the given record field. *)
+    let recfield_target t f = target mark_type_elt
+      (Printf.sprintf "%s.%s" (Name.simple t.ty_name) f.rf_name)
+
     (** Return the complete link target for the given type. *)
     let complete_type_target t = complete_target mark_type t.ty_name
 
+    let complete_recfield_target name =
+      let typ = Name.father name in
+      let field = Name.simple name in
+      Printf.sprintf "%s.%s" (complete_target mark_type_elt typ) field
+
+    let complete_const_target = complete_recfield_target
+
     (** Return the link target for the given exception. *)
     let exception_target e = target mark_exception (Name.simple e.ex_name)
 
@@ -270,7 +296,7 @@ class virtual text =
     method html_of_Raw b s = bs b (self#escape s)
 
     method html_of_Code b s =
-      if !Args.colorize_code then
+      if !colorize_code then
         self#html_of_code b ~with_pre: false s
       else
         (
@@ -308,7 +334,7 @@ class virtual text =
               | Some last -> String.sub s first ((last-first)+1)
         in
         fun b s ->
-      if !Args.colorize_code then
+      if !colorize_code then
         (
          bs b "<pre></pre>";
          self#html_of_code b (remove_useless_newlines s);
@@ -433,6 +459,8 @@ class virtual text =
             | Odoc_info.RK_method -> (Naming.complete_target Naming.mark_method name, h name)
             | Odoc_info.RK_section t -> (Naming.complete_label_target name,
                                          Odoc_info.Italic [Raw (Odoc_info.string_of_text t)])
+            | Odoc_info.RK_recfield -> (Naming.complete_recfield_target name, h name)
+            | Odoc_info.RK_const -> (Naming.complete_const_target name, h name)
           in
           let text =
             match text_opt with
@@ -471,7 +499,7 @@ class virtual text =
              self#html_of_info_first_sentence b m.m_info;
            with
              Not_found ->
-               Odoc_messages.pwarning (Odoc_messages.cross_module_not_found name);
+               Odoc_global.pwarning (Odoc_messages.cross_module_not_found name);
                bp b "%s</td><td>" name
           );
           bs b "</td></tr>\n"
@@ -724,6 +752,8 @@ let newline_to_indented_br s =
   done;
   Buffer.contents b
 
+module Generator =
+  struct
 (** This class is used to create objects which can generate a simple html documentation. *)
 class html =
   object (self)
@@ -735,7 +765,7 @@ class html =
     method character_encoding () =
       Printf.sprintf
         "<meta content=\"text/html; charset=%s\" http-equiv=\"Content-Type\">\n"
-        !Odoc_info.Args.charset
+        !charset
 
     (** The default style options. *)
     val mutable default_style_options =
@@ -832,10 +862,10 @@ class html =
     val mutable known_modules_names = StringSet.empty
 
     method index_prefix =
-      if !Odoc_args.out_file = Odoc_messages.default_out_file then
+      if !Odoc_global.out_file = Odoc_messages.default_out_file then
         "index"
       else
-        Filename.basename !Odoc_args.out_file
+        Filename.basename !Odoc_global.out_file
 
     (** The main file. *)
     method index =
@@ -895,12 +925,12 @@ class html =
 
     (** Init the style. *)
     method init_style =
-      (match !Args.css_style with
+      (match !css_style with
         None ->
           let default_style = String.concat "\n" default_style_options in
           (
            try
-             let file = Filename.concat !Args.target_dir style_file in
+             let file = Filename.concat !Global.target_dir style_file in
              if Sys.file_exists file then
                Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
              else
@@ -922,7 +952,7 @@ class html =
       style <- "<link rel=\"stylesheet\" href=\""^style_file^"\" type=\"text/css\">\n"
 
     (** Get the title given by the user *)
-    method title = match !Args.title with None -> "" | Some t -> self#escape t
+    method title = match !Global.title with None -> "" | Some t -> self#escape t
 
     (** Get the title given by the user completed with the given subtitle. *)
     method inner_title s =
@@ -1212,7 +1242,7 @@ class html =
           bs b (self#create_fully_qualified_module_idents_links father a.ma_name);
           bs b "</code>"
       | Module_functor (p, k) ->
-          if !Odoc_info.Args.html_short_functors then
+          if !html_short_functors then
             bs b " "
           else
             bs b "<div class=\"sig_block\">";
@@ -1220,12 +1250,12 @@ class html =
           (
            match k with
              Module_functor _ -> ()
-           | _ when !Odoc_info.Args.html_short_functors ->
+           | _ when !html_short_functors ->
                bs b ": "
            | _ -> ()
           );
           self#html_of_module_kind b father ?modu k;
-          if not !Odoc_info.Args.html_short_functors then
+          if not !html_short_functors then
             bs b "</div>"
       | Module_apply (k1, k2) ->
           (* TODO: l'application n'est pas correcte dans un .mli.
@@ -1235,7 +1265,7 @@ class html =
           self#html_of_module_kind b father k2;
           self#html_of_text b [Code ")"]
       | Module_with (k, s) ->
-          (* TODO: à modifier quand Module_with sera plus détaillé *)
+          (* TODO: à modifier quand Module_with sera plus détaillé *)
           self#html_of_module_type_kind b father ?modu k;
           bs b "<code class=\"type\"> ";
           bs b (self#create_fully_qualified_module_idents_links father s);
@@ -1262,7 +1292,7 @@ class html =
 
     method html_of_module_parameter b father p =
       let (s_functor,s_arrow) =
-        if !Odoc_info.Args.html_short_functors then
+        if !html_short_functors then
           "", ""
         else
           "functor ", "-> "
@@ -1363,7 +1393,7 @@ class html =
          None -> bs b (self#escape (Name.simple v.val_name))
        | Some c ->
            let file = Naming.file_code_value_complete_target v in
-           self#output_code v.val_name (Filename.concat !Args.target_dir file) c;
+           self#output_code v.val_name (Filename.concat !Global.target_dir file) c;
            bp b "<a href=\"%s\">%s</a>" file (self#escape (Name.simple v.val_name))
       );
       bs b "</span>";
@@ -1372,7 +1402,7 @@ class html =
       bs b "</pre>";
       self#html_of_info b v.val_info;
       (
-       if !Args.with_parameter_list then
+       if !with_parameter_list then
          self#html_of_parameter_list b (Name.father v.val_name) v.val_parameters
        else
          self#html_of_described_parameter_list b (Name.father v.val_name) v.val_parameters
@@ -1457,13 +1487,23 @@ class html =
             bs b (self#keyword "|");
             bs b "</code></td>\n<td align=\"left\" valign=\"top\" >\n";
             bs b "<code>";
-            bs b (self#constructor constr.vc_name);
+            bp b "<span id=\"%s\">%s</span>"
+              (Naming.const_target t constr)
+              (self#constructor constr.vc_name);
             (
-             match constr.vc_args with
-               [] -> ()
-             | l ->
+             match constr.vc_args, constr.vc_ret with
+               [], None -> ()
+             | l,None ->
                  bs b (" " ^ (self#keyword "of") ^ " ");
                  self#html_of_type_expr_list ~par: false b father " * " l;
+             | [],Some r ->
+                 bs b (" " ^ (self#keyword ":") ^ " ");
+                 self#html_of_type_expr b father r;
+             | l,Some r ->
+                 bs b (" " ^ (self#keyword ":") ^ " ");
+                 self#html_of_type_expr_list ~par: false b father " * " l;
+                bs b (" " ^ (self#keyword "->") ^ " ");
+                 self#html_of_type_expr b father r;
             );
             bs b "</code></td>\n";
             (
@@ -1504,7 +1544,9 @@ class html =
             bs b "</td>\n<td align=\"left\" valign=\"top\" >\n";
             bs b "<code>";
             if r.rf_mutable then bs b (self#keyword "mutable&nbsp;") ;
-            bs b (r.rf_name ^ "&nbsp;: ") ;
+            bp b "<span id=\"%s\">%s</span>&nbsp;:"
+              (Naming.recfield_target t r)
+              r.rf_name;
             self#html_of_type_expr b father r.rf_type;
             bs b ";</code></td>\n";
             (
@@ -1552,7 +1594,7 @@ class html =
          None -> bs b (Name.simple a.att_value.val_name)
        | Some c ->
            let file = Naming.file_code_attribute_complete_target a in
-           self#output_code a.att_value.val_name (Filename.concat !Args.target_dir file) c;
+           self#output_code a.att_value.val_name (Filename.concat !Global.target_dir file) c;
            bp b "<a href=\"%s\">%s</a>" file (Name.simple a.att_value.val_name);
       );
       bs b "</span>";
@@ -1575,7 +1617,7 @@ class html =
          None -> bs b  (Name.simple m.met_value.val_name)
        | Some c ->
            let file = Naming.file_code_method_complete_target m in
-           self#output_code m.met_value.val_name (Filename.concat !Args.target_dir file) c;
+           self#output_code m.met_value.val_name (Filename.concat !Global.target_dir file) c;
            bp b "<a href=\"%s\">%s</a>" file (Name.simple m.met_value.val_name);
       );
       bs b "</span>";
@@ -1584,7 +1626,7 @@ class html =
       bs b "</pre>";
       self#html_of_info b m.met_value.val_info;
       (
-       if !Args.with_parameter_list then
+       if !with_parameter_list then
          self#html_of_parameter_list b
            module_name m.met_value.val_parameters
        else
@@ -1718,7 +1760,7 @@ class html =
       );
       (
        match m.m_kind with
-         Module_functor _ when !Odoc_info.Args.html_short_functors  ->
+         Module_functor _ when !html_short_functors  ->
            ()
        | _ -> bs b ": "
       );
@@ -1817,7 +1859,7 @@ class html =
           self#html_of_text b [Code "end"]
 
       | Class_apply capp ->
-          (* TODO: afficher le type final à partir du typedtree *)
+          (* TODO: afficher le type final à partir du typedtree *)
           self#html_of_text b [Raw "class application not handled yet"]
 
       | Class_constr cco ->
@@ -2064,7 +2106,7 @@ class html =
               ('a -> string) -> string -> string -> unit =
     fun elements name info target title simple_file ->
       try
-        let chanout = open_out (Filename.concat !Args.target_dir simple_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir simple_file) in
         let b = new_buf () in
         bs b "<html>\n";
         self#print_header b (self#inner_title title);
@@ -2130,7 +2172,7 @@ class html =
       let (html_file, _) = Naming.html_files cl.cl_name in
       let type_file = Naming.file_type_class_complete_target cl.cl_name in
       try
-        let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir html_file) in
         let b = new_buf () in
         let pre_name = opt (fun c -> c.cl_name) pre in
         let post_name = opt (fun c -> c.cl_name) post in
@@ -2165,7 +2207,7 @@ class html =
         (* generate the file with the complete class type *)
         self#output_class_type
           cl.cl_name
-          (Filename.concat !Args.target_dir type_file)
+          (Filename.concat !Global.target_dir type_file)
           cl.cl_type
       with
         Sys_error s ->
@@ -2177,7 +2219,7 @@ class html =
       let (html_file, _) = Naming.html_files clt.clt_name in
       let type_file = Naming.file_type_class_complete_target clt.clt_name in
       try
-        let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir html_file) in
         let b = new_buf () in
         let pre_name = opt (fun ct -> ct.clt_name) pre in
         let post_name = opt (fun ct -> ct.clt_name) post in
@@ -2211,7 +2253,7 @@ class html =
         (* generate the file with the complete class type *)
         self#output_class_type
           clt.clt_name
-          (Filename.concat !Args.target_dir type_file)
+          (Filename.concat !Global.target_dir type_file)
           clt.clt_type
       with
         Sys_error s ->
@@ -2223,7 +2265,7 @@ class html =
       try
         let (html_file, _) = Naming.html_files mt.mt_name in
         let type_file = Naming.file_type_module_complete_target mt.mt_name in
-        let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir html_file) in
         let b = new_buf () in
         let pre_name = opt (fun mt -> mt.mt_name) pre in
         let post_name = opt (fun mt -> mt.mt_name) post in
@@ -2276,7 +2318,7 @@ class html =
          | Some mty ->
              self#output_module_type
                mt.mt_name
-               (Filename.concat !Args.target_dir type_file)
+               (Filename.concat !Global.target_dir type_file)
                mty
         )
       with
@@ -2291,7 +2333,7 @@ class html =
         let (html_file, _) = Naming.html_files modu.m_name in
         let type_file = Naming.file_type_module_complete_target modu.m_name in
         let code_file = Naming.file_code_module_complete_target modu.m_name in
-        let chanout = open_out (Filename.concat !Args.target_dir html_file) in
+        let chanout = open_out (Filename.concat !Global.target_dir html_file) in
         let b = new_buf () in
         let pre_name = opt (fun m -> m.m_name) pre in
         let post_name = opt (fun m -> m.m_name) post in
@@ -2355,7 +2397,7 @@ class html =
         (* generate the file with the complete module type *)
         self#output_module_type
           modu.m_name
-          (Filename.concat !Args.target_dir type_file)
+          (Filename.concat !Global.target_dir type_file)
           modu.m_type;
 
         match modu.m_code with
@@ -2363,7 +2405,7 @@ class html =
         | Some code ->
             self#output_code
               modu.m_name
-              (Filename.concat !Args.target_dir code_file)
+              (Filename.concat !Global.target_dir code_file)
               code
       with
         Sys_error s ->
@@ -2373,9 +2415,9 @@ class html =
        @raise Failure if an error occurs.*)
     method generate_index module_list =
       try
-        let chanout = open_out (Filename.concat !Args.target_dir self#index) in
+        let chanout = open_out (Filename.concat !Global.target_dir self#index) in
         let b = new_buf () in
-        let title = match !Args.title with None -> "" | Some t -> self#escape t in
+        let title = match !Global.title with None -> "" | Some t -> self#escape t in
         bs b doctype ;
         bs b "<html>\n";
         self#print_header b self#title;
@@ -2385,7 +2427,7 @@ class html =
         bs b "</h1></center>\n" ;
         let info = Odoc_info.apply_opt
             (Odoc_info.info_of_comment_file module_list)
-            !Odoc_info.Args.intro_file
+            !Odoc_info.Global.intro_file
         in
         (
          match info with
@@ -2545,7 +2587,7 @@ class html =
           known_modules_names
           module_types ;
       (* generate html for each module *)
-      if not !Args.index_only then
+      if not !index_only then
         self#generate_elements self#generate_for_module module_list ;
 
       try
@@ -2572,3 +2614,6 @@ class html =
           Buffer.contents b
         )
   end
+end
+
+module type Html_generator = module type of Generator

diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml
index fa3c585ed675d6083168a559f5ba92d8e5014654..4cd4a3e3b1a7b8092185429c94dffcad90a2f0de 100644 (file)
--- a/ocamldoc/odoc_info.ml
+++ b/ocamldoc/odoc_info.ml
@@ -24,6 +24,8 @@ type ref_kind = Odoc_types.ref_kind =
   | RK_attribute
   | RK_method
   | RK_section of text
+  | RK_recfield
+  | RK_const
 
 and text_element = Odoc_types.text_element =
   | Raw of string
@@ -104,11 +106,11 @@ let analyse_files
     ?(no_stop=false)
     ?(init=[])
     files =
-  Odoc_args.merge_options := merge_options;
-  Odoc_args.include_dirs := include_dirs;
-  Odoc_args.classic := not labels;
-  Odoc_args.sort_modules := sort_modules;
-  Odoc_args.no_stop := no_stop;
+  Odoc_global.merge_options := merge_options;
+  Odoc_global.include_dirs := include_dirs;
+  Odoc_global.classic := not labels;
+  Odoc_global.sort_modules := sort_modules;
+  Odoc_global.no_stop := no_stop;
   Odoc_analyse.analyse_files ~init: init files
 
 let dump_modules = Odoc_analyse.dump_modules
@@ -168,15 +170,15 @@ let is_optional = Odoc_misc.is_optional
 let label_name = Odoc_misc.label_name
 
 let use_hidden_modules n =
-  Odoc_name.hide_given_modules !Odoc_args.hidden_modules n
+  Odoc_name.hide_given_modules !Odoc_global.hidden_modules n
 
 let verbose s =
-  if !Odoc_args.verbose then
+  if !Odoc_global.verbose then
     (print_string s ; print_newline ())
   else
     ()
 
-let warning s = Odoc_messages.pwarning s
+let warning s = Odoc_global.pwarning s
 let print_warnings = Odoc_config.print_warnings
 
 let errors = Odoc_global.errors
@@ -213,12 +215,12 @@ let info_string_of_info i =
    | Some t -> p b "%s" (escape_arobas (text_string_of_text t))
   );
   List.iter
-    (fun s -> p b "\n@author %s" (escape_arobas s))
+    (fun s -> p b "\n@@author %s" (escape_arobas s))
     i.i_authors;
   (
    match i.i_version with
      None -> ()
-   | Some s -> p b "\n@version %s" (escape_arobas s)
+   | Some s -> p b "\n@@version %s" (escape_arobas s)
   );
   (
    (* TODO: escape characters ? *)
@@ -229,7 +231,7 @@ let info_string_of_info i =
    in
    List.iter
      (fun (sref, t) ->
-       p b "\n@see %s %s"
+       p b "\n@@see %s %s"
          (escape_arobas (f_see_ref sref))
          (escape_arobas (text_string_of_text t))
      )
@@ -238,25 +240,25 @@ let info_string_of_info i =
   (
    match i.i_since with
      None -> ()
-   | Some s -> p b "\n@since %s" (escape_arobas s)
+   | Some s -> p b "\n@@since %s" (escape_arobas s)
   );
   (
    match i.i_deprecated with
      None -> ()
    | Some t ->
-       p b "\n@deprecated %s"
+       p b "\n@@deprecated %s"
          (escape_arobas (text_string_of_text t))
   );
   List.iter
     (fun (s, t) ->
-      p b "\n@param %s %s"
+      p b "\n@@param %s %s"
         (escape_arobas s)
         (escape_arobas (text_string_of_text t))
     )
     i.i_params;
   List.iter
     (fun (s, t) ->
-      p b "\n@raise %s %s"
+      p b "\n@@raise %s %s"
         (escape_arobas s)
         (escape_arobas (text_string_of_text t))
     )
@@ -265,12 +267,12 @@ let info_string_of_info i =
    match i.i_return_value with
      None -> ()
    | Some t ->
-       p b "\n@return %s"
+       p b "\n@@return %s"
          (escape_arobas (text_string_of_text t))
   );
   List.iter
     (fun (s, t) ->
-      p b "\n@%s %s" s
+      p b "\n@@%s %s" s
         (escape_arobas (text_string_of_text t))
     )
     i.i_custom;
@@ -293,6 +295,8 @@ module Search =
         | Res_attribute of Value.t_attribute
         | Res_method of Value.t_method
         | Res_section of string * text
+        | Res_recfield of Type.t_type * Type.record_field
+        | Res_const of Type.t_type * Type.variant_constructor
 
     type search_result = result_element list
 
@@ -320,4 +324,4 @@ module Dep =
     let deps_of_types = Odoc_dep.deps_of_types
   end
 
-module Args = Odoc_args
+module Global = Odoc_global

diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli
index c12e451ae2f710038defcf0e97189f874c63cf72..a3fc5975b8991ed467d14041764d0366e51d6b92 100644 (file)
--- a/ocamldoc/odoc_info.mli
+++ b/ocamldoc/odoc_info.mli
@@ -25,6 +25,8 @@ type ref_kind = Odoc_types.ref_kind =
   | RK_attribute
   | RK_method
   | RK_section of text
+  | RK_recfield
+  | RK_const
 
 and text_element = Odoc_types.text_element =
   | Raw of string (** Raw text. *)
@@ -201,6 +203,7 @@ module Type :
         {
           vc_name : string ; (** Name of the constructor. *)
           vc_args : Types.type_expr list ; (** Arguments of the constructor. *)
+         vc_ret : Types.type_expr option ;
           mutable vc_text : text option ; (** Optional description in the associated comment. *)
         }
 
@@ -791,6 +794,8 @@ module Search :
         | Res_attribute of Value.t_attribute
         | Res_method of Value.t_method
         | Res_section of string  * text
+        | Res_recfield of Type.t_type * Type.record_field
+        | Res_const of Type.t_type * Type.variant_constructor
 
       (** The type representing a research result.*)
       type search_result = result_element list
@@ -835,6 +840,10 @@ module Scan :
       (** Scan of 'leaf elements'. *)
 
         method scan_value : Value.t_value -> unit
+
+        method scan_type_pre : Type.t_type -> bool
+        method scan_type_const : Type.t_type -> Type.variant_constructor -> unit
+        method scan_type_recfield : Type.t_type -> Type.record_field -> unit
         method scan_type : Type.t_type -> unit
         method scan_exception : Exception.t_exception -> unit
         method scan_attribute : Value.t_attribute -> unit
@@ -931,152 +940,40 @@ module Dep :
     val deps_of_types : ?kernel: bool -> Type.t_type list -> (Type.t_type * (Name.t list)) list
   end
 
-(** {2 Command line arguments} *)
-
-(**  You can use this module to create custom generators.*)
-module Args :
-    sig
-      (** The kind of source file in arguments. *)
-      type source_file =
-          Impl_file of string
-        | Intf_file of string
-        | Text_file of string
-
-      (** The class type of documentation generators. *)
-      class type doc_generator =
-        object method generate : Module.t_module list -> unit end
-
-      (** The file used by the generators outputting only one file. *)
-      val out_file : string ref
-
-      (** Verbose mode or not. *)
-      val verbose : bool ref
-
-      (** The optional title to use in the generated documentation. *)
-      val title : string option ref
-
-      (** To inverse [.ml] and [.mli] files while merging comments. *)
-      val inverse_merge_ml_mli : bool ref
-
-      (** To filter module elements according to module type constraints. *)
-      val filter_with_module_constraints : bool ref
-
-      (** To keep the code while merging, when we have both .ml and .mli files for a module. *)
-      val keep_code : bool ref
-
-      (** The optional file whose content can be used as intro text. *)
-      val intro_file : string option ref
-
-      (** Flag to indicate whether we must display the complete list of parameters
-         for functions and methods. *)
-      val with_parameter_list : bool ref
-
-      (** The list of module names to hide. *)
-      val hidden_modules : string list ref
-
-      (** The directory where files have to be generated. *)
-      val target_dir : string ref
-
-      (** An optional file to use where a CSS style is defined (for HTML). *)
-      val css_style : string option ref
-
-      (** Generate only index files. (for HTML). *)
-      val index_only : bool ref
-
-      (** To colorize code in HTML generated documentation pages, not code pages. *)
-      val colorize_code : bool ref
-
-      (** To display functors in short form rather than with "functor ... -> ",
-         in HTML generated documentation. *)
-      val html_short_functors : bool ref
-
-      (** Character encoding used in HTML pages header. *)
-      val charset : string ref
-
-      (** The flag which indicates if we must generate a header (for LaTeX). *)
-      val with_header : bool ref
+(** {2 Some global variables} *)
 
-      (** The flag which indicates if we must generate a trailer (for LaTeX). *)
-      val with_trailer : bool ref
-
-      (** The flag to indicate if we must generate one file per module (for LaTeX). *)
-      val separate_files : bool ref
-
-      (** The list of pairs (title level, sectionning style). *)
-      val latex_titles : (int * string) list ref
-
-      (** The prefix to use for value labels in LaTeX. *)
-      val latex_value_prefix : string ref
-
-      (** The prefix to use for type labels in LaTeX. *)
-      val latex_type_prefix : string ref
-
-      (** The prefix to use for exception labels in LaTeX. *)
-      val latex_exception_prefix : string ref
-
-      (** The prefix to use for module labels in LaTeX. *)
-      val latex_module_prefix : string ref
-
-      (** The prefix to use for module type labels in LaTeX. *)
-      val latex_module_type_prefix : string ref
-
-      (** The prefix to use for class labels in LaTeX. *)
-      val latex_class_prefix : string ref
-
-      (** The prefix to use for class type labels in LaTeX. *)
-      val latex_class_type_prefix : string ref
-
-      (** The prefix to use for attribute labels in LaTeX. *)
-      val latex_attribute_prefix : string ref
-
-      (** The prefix to use for method labels in LaTeX. *)
-      val latex_method_prefix : string ref
-
-      (** The flag which indicates if we must generate a table of contents (for LaTeX). *)
-      val with_toc : bool ref
-
-      (** The flag which indicates if we must generate an index (for TeXinfo). *)
-      val with_index : bool ref
-
-      (** The flag which indicates if we must escape accentuated characters (for TeXinfo).*)
-      val esc_8bits : bool ref
-
-      (** The Info directory section *)
-      val info_section : string ref
-
-      (** The Info directory entries to insert *)
-      val info_entry : string list ref
-
-      (** Include all modules or only the ones on the command line, for the dot output. *)
-      val dot_include_all : bool ref
+module Global :
+  sig
+    val errors : int ref
+    val warn_error : bool ref
 
-      (** Generate dependency graph for types. *)
-      val dot_types : bool ref
+    (** The file used by the generators outputting only one file. *)
+    val out_file : string ref
 
-      (** Perform transitive reduction before dot output. *)
-      val dot_reduce : bool ref
+    (** Verbose mode or not. *)
+    val verbose : bool ref
 
-      (** The colors used in the dot output. *)
-      val dot_colors : string list ref
+    (** The directory where files have to be generated. *)
+    val target_dir : string ref
 
-      (** The suffix for man pages. *)
-      val man_suffix : string ref
+    (** The optional title to use in the generated documentation. *)
+    val title : string option ref
 
-      (** The section for man pages. *)
-      val man_section : string ref
+    (** The optional file whose content can be used as intro text. *)
+    val intro_file : string option ref
 
-      (** The flag to generate all man pages or only for modules and classes.*)
-      val man_mini : bool ref
+    (** The flag which indicates if we must generate a table of contents. *)
+    val with_toc : bool ref
 
-      (** The files to be analysed. *)
-      val files : source_file list ref
+    (** The flag which indicates if we must generate an index. *)
+    val with_index : bool ref
 
-      (** To set the documentation generator. *)
-      val set_doc_generator : doc_generator option -> unit
+    (** The flag which indicates if we must generate a header.*)
+    val with_header : bool ref
 
-      (** Add an option specification. *)
-      val add_option : string * Arg.spec * string -> unit
-    end
+    (** The flag which indicates if we must generate a trailer.*)
+    val with_trailer : bool ref
+end
 
 (** Analysis of the given source files.
    @param init is the list of modules already known from a previous analysis.
@@ -1088,7 +985,7 @@ val analyse_files :
           ?sort_modules:bool ->
             ?no_stop:bool ->
               ?init: Odoc_module.t_module list ->
-                Args.source_file list ->
+                Odoc_global.source_file list ->
                   Module.t_module list
 
 (** Dump of a list of modules into a file.

diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml
index 3750996a452086de1adbdee5075ad21ea983ab9a..f2bff2172a4646435f9a6a593534c490f014ae75 100644 (file)
--- a/ocamldoc/odoc_latex.ml
+++ b/ocamldoc/odoc_latex.ml
@@ -23,6 +23,29 @@ open Exception
 open Class
 open Module
 
+
+
+let separate_files = ref false
+
+let latex_titles = ref [
+  1, "section" ;
+  2, "subsection" ;
+  3, "subsubsection" ;
+  4, "paragraph" ;
+  5, "subparagraph" ;
+]
+
+let latex_value_prefix = ref Odoc_messages.default_latex_value_prefix
+let latex_type_prefix = ref Odoc_messages.default_latex_type_prefix
+let latex_type_elt_prefix = ref Odoc_messages.default_latex_type_elt_prefix
+let latex_exception_prefix = ref Odoc_messages.default_latex_exception_prefix
+let latex_module_prefix = ref Odoc_messages.default_latex_module_prefix
+let latex_module_type_prefix = ref Odoc_messages.default_latex_module_type_prefix
+let latex_class_prefix = ref Odoc_messages.default_latex_class_prefix
+let latex_class_type_prefix = ref Odoc_messages.default_latex_class_type_prefix
+let latex_attribute_prefix = ref Odoc_messages.default_latex_attribute_prefix
+let latex_method_prefix = ref Odoc_messages.default_latex_method_prefix
+
 let new_buf () = Buffer.create 1024
 let new_fmt () =
   let b = new_buf () in
@@ -60,81 +83,91 @@ class text =
        and with the given latex code. *)
     method section_style level s =
       try
-        let sec = List.assoc level !Args.latex_titles in
+        let sec = List.assoc level !latex_titles in
         "\\"^sec^"{"^s^"}\n"
       with Not_found -> s
 
-    (** Associations of strings to subsitute in latex code. *)
-    val mutable subst_strings = [
-      ("MAXENCE"^"ZZZ", "\\$");
-      ("MAXENCE"^"YYY", "\\&");
-      ("MAXENCE"^"XXX", "{\\textbackslash}") ;
-      ("à", "\\`a") ;
-      ("â", "\\^a") ;
-      ("é", "\\'e") ;
-      ("è", "\\`e") ;
-      ("ê", "\\^e") ;
-      ("ë", "\\\"e") ;
-      ("ç", "\\c{c}") ;
-      ("ô", "\\^o") ;
-      ("ö", "\\\"o") ;
-      ("î", "\\^i") ;
-      ("ï", "\\\"i") ;
-      ("ù", "\\`u") ;
-      ("û", "\\^u") ;
-      ("%", "\\%") ;
-      ("_", "\\_");
-      ("\\.\\.\\.", "$\\ldots$");
-      ("~", "\\~{}");
-      ("#", "\\verb`#`");
-      ("}", "\\}");
-      ("{", "\\{");
-      ("&", "\\&");
-      (">", "$>$");
-      ("<", "$<$");
-      ("=", "$=$");
-      (">=", "$\\geq$");
-      ("<=", "$\\leq$");
-      ("->", "$\\rightarrow$") ;
-      ("<-", "$\\leftarrow$");
-      ("|", "\\textbar ");
-      ("\\^", "\\textasciicircum ") ;
-      ("\\.\\.\\.", "$\\ldots$");
-      ("\\\\", "MAXENCE"^"XXX") ;
-      ("&", "MAXENCE"^"YYY") ;
-      ("\\$", "MAXENCE"^"ZZZ");
-    ]
-
-    val mutable subst_strings_simple =
+    (** Associations of strings to substitute in latex code. *)
+    val subst_strings = List.map (fun (x, y) -> (Str.regexp x, y))
       [
-        ("MAXENCE"^"XXX", "{\\textbackslash}") ;
-        "}", "\\}" ;
-        "{", "\\{" ;
-        ("\\\\", "MAXENCE"^"XXX") ;
+        "\001", "\001\002";
+        "\\\\", "\001b";
+
+        "{", "\\\\{";
+        "}", "\\\\}";
+        "\\$", "\\\\$";
+        "\\^", "{\\\\textasciicircum}";
+        "à", "\\\\`a";
+        "â", "\\\\^a";
+        "é", "\\\\'e";
+        "è", "\\\\`e";
+        "ê", "\\\\^e";
+        "ë", "\\\\\"e";
+        "ç", "\\\\c{c}";
+        "ô", "\\\\^o";
+        "ö", "\\\\\"o";
+        "î", "\\\\^i";
+        "ï", "\\\\\"i";
+        "ù", "\\\\`u";
+        "û", "\\\\^u";
+        "%", "\\\\%";
+        "_", "\\\\_";
+        "~", "\\\\~{}";
+        "#", "{\\char35}";
+        "->", "$\\\\rightarrow$";
+        "<-", "$\\\\leftarrow$";
+        ">=", "$\\\\geq$";
+        "<=", "$\\\\leq$";
+        ">", "$>$";
+        "<", "$<$";
+        "=", "$=$";
+        "|", "{\\\\textbar}";
+        "\\.\\.\\.", "$\\\\ldots$";
+        "&", "\\\\&";
+
+        "\001b", "{\\\\char92}";
+        "\001\002", "\001";
       ]
 
-    val mutable subst_strings_code = [
-      ("MAXENCE"^"ZZZ", "\\$");
-      ("MAXENCE"^"YYY", "\\&");
-      ("MAXENCE"^"XXX", "{\\textbackslash}") ;
-      ("%", "\\%") ;
-      ("_", "\\_");
-      ("~", "\\~{}");
-      ("#", "\\verb`#`");
-      ("}", "\\}");
-      ("{", "\\{");
-      ("&", "\\&");
-      ("\\^", "\\textasciicircum ") ;
-      ("&", "MAXENCE"^"YYY") ;
-      ("\\$", "MAXENCE"^"ZZZ") ;
-      ("\\\\", "MAXENCE"^"XXX") ;
-     ]
+    val subst_strings_simple = List.map (fun (x, y) -> (Str.regexp x, y))
+      [
+        "\001", "\001\002";
+        "\\\\", "\001b";
+        "{", "\001l";
+
+        "}", "{\\\\char125}";
+        "'", "{\\\\textquotesingle}";
+        "`", "{\\\\textasciigrave}";
+
+        "\001b", "{\\\\char92}";
+        "\001l", "{\\\\char123}";
+        "\001\002", "\001";
+      ]
+
+    val subst_strings_code = List.map (fun (x, y) -> (Str.regexp x, y))
+      [
+        "\001", "\001\002";
+        "\\\\", "\001b";
+        "{", "\001l";
+
+        "}", "{\\\\char125}";
+        "'", "{\\\\textquotesingle}";
+        "`", "{\\\\textasciigrave}";
+        "%", "\\\\%";
+        "_", "\\\\_";
+        "~", "{\\\\char126}";
+        "#", "{\\\\char35}";
+        "&", "\\\\&";
+        "\\$", "\\\\$";
+        "\\^", "{\\\\char94}";
+
+        "\001b", "{\\\\char92}";
+        "\001l", "{\\\\char123}";
+        "\001\002", "\001";
+      ]
 
     method subst l s =
-      List.fold_right
-        (fun (s, s2) -> fun acc -> Str.global_replace (Str.regexp s) s2 acc)
-        l
-        s
+      List.fold_left (fun acc (re, st) -> Str.global_replace re st acc) s l
 
     (** Escape the strings which would clash with LaTeX syntax. *)
     method escape s = self#subst subst_strings s
@@ -182,31 +215,37 @@ class text =
       Buffer.contents buf
 
     (** Make a correct label from a value name. *)
-    method value_label ?no_ name = !Args.latex_value_prefix^(self#label ?no_ name)
+    method value_label ?no_ name = !latex_value_prefix^(self#label ?no_ name)
 
     (** Make a correct label from an attribute name. *)
-    method attribute_label ?no_ name = !Args.latex_attribute_prefix^(self#label ?no_ name)
+    method attribute_label ?no_ name = !latex_attribute_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a method name. *)
-    method method_label ?no_ name = !Args.latex_method_prefix^(self#label ?no_ name)
+    method method_label ?no_ name = !latex_method_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a class name. *)
-    method class_label ?no_ name = !Args.latex_class_prefix^(self#label ?no_ name)
+    method class_label ?no_ name = !latex_class_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a class type name. *)
-    method class_type_label ?no_ name = !Args.latex_class_type_prefix^(self#label ?no_ name)
+    method class_type_label ?no_ name = !latex_class_type_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a module name. *)
-    method module_label ?no_ name = !Args.latex_module_prefix^(self#label ?no_ name)
+    method module_label ?no_ name = !latex_module_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a module type name. *)
-    method module_type_label ?no_ name = !Args.latex_module_type_prefix^(self#label ?no_ name)
+    method module_type_label ?no_ name = !latex_module_type_prefix^(self#label ?no_ name)
 
     (** Make a correct label from an exception name. *)
-    method exception_label ?no_ name = !Args.latex_exception_prefix^(self#label ?no_ name)
+    method exception_label ?no_ name = !latex_exception_prefix^(self#label ?no_ name)
 
     (** Make a correct label from a type name. *)
-    method type_label ?no_ name = !Args.latex_type_prefix^(self#label ?no_ name)
+    method type_label ?no_ name = !latex_type_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a record field. *)
+    method recfield_label ?no_ name = !latex_type_elt_prefix^(self#label ?no_ name)
+
+    (** Make a correct label from a variant constructor. *)
+    method const_label ?no_ name = !latex_type_elt_prefix^(self#label ?no_ name)
 
     (** Return latex code for the label of a given label. *)
     method make_label label = "\\label{"^label^"}"
@@ -269,9 +308,9 @@ class text =
       ps fmt "\n\\end{ocamldoccode}\n"
 
     method latex_of_Verbatim fmt s =
-      ps fmt "\\begin{verbatim}";
+      ps fmt "\n\\begin{verbatim}\n";
       ps fmt s;
-      ps fmt "\\end{verbatim}"
+      ps fmt "\n\\end{verbatim}\n"
 
     method latex_of_Bold fmt t =
       ps fmt "{\\bf ";
@@ -377,6 +416,8 @@ class text =
             | Odoc_info.RK_attribute -> self#attribute_label
             | Odoc_info.RK_method -> self#method_label
             | Odoc_info.RK_section _ -> assert false
+            | Odoc_info.RK_recfield -> self#recfield_label
+            | Odoc_info.RK_const -> self#const_label
           in
           let text =
             match text_opt with
@@ -413,6 +454,8 @@ class virtual info =
         (self#text_of_info ~block info_opt)
   end
 
+module Generator =
+struct
 (** This class is used to create objects which can generate a simple LaTeX documentation. *)
 class latex =
   object (self)
@@ -517,12 +560,22 @@ class latex =
                     let s_cons =
                       p fmt2 "@[<h 6>  | %s" constr.vc_name;
                       (
-                       match constr.vc_args with
-                         [] -> ()
-                       | l ->
+                       match constr.vc_args, constr.vc_ret with
+                         [], None -> ()
+                       | l, None ->
                            p fmt2 " %s@ %s"
                              "of"
                              (self#normal_type_list ~par: false mod_name " * " l)
+                       | [], Some r ->
+                           p fmt2 " %s@ %s"
+                             ":"
+                             (self#normal_type mod_name r)
+                       | l, Some r ->
+                           p fmt2 " %s@ %s@ %s@ %s"
+                             ":"
+                             (self#normal_type_list ~par: false mod_name " * " l)
+                            "->"
+                             (self#normal_type mod_name r)
                       );
                       flush2 ()
                     in
@@ -650,7 +703,7 @@ class latex =
           self#latex_of_module_kind fmt father k2;
           self#latex_of_text fmt [Code ")"]
       | Module_with (k, s) ->
-          (* TODO: à modifier quand Module_with sera plus détaillé *)
+          (* TODO: à modifier quand Module_with sera plus détaillé *)
           self#latex_of_module_type_kind fmt father k;
           self#latex_of_text fmt
             [ Code " ";
@@ -679,7 +732,7 @@ class latex =
           self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"]
 
       | Class_apply capp ->
-          (* TODO: afficher le type final à partir du typedtree *)
+          (* TODO: afficher le type final à partir du typedtree *)
           self#latex_of_text fmt [Raw "class application not handled yet"]
 
       | Class_constr cco ->
@@ -1078,11 +1131,12 @@ class latex =
       ps fmt "\\documentclass[11pt]{article} \n";
       ps fmt "\\usepackage[latin1]{inputenc} \n";
       ps fmt "\\usepackage[T1]{fontenc} \n";
+      ps fmt "\\usepackage{textcomp}\n";
       ps fmt "\\usepackage{fullpage} \n";
       ps fmt "\\usepackage{url} \n";
       ps fmt "\\usepackage{ocamldoc}\n";
       (
-       match !Args.title with
+       match !Global.title with
          None -> ()
        | Some s ->
            ps fmt "\\title{";
@@ -1090,15 +1144,15 @@ class latex =
            ps fmt "}\n"
       );
       ps fmt "\\begin{document}\n";
-      (match !Args.title with
+      (match !Global.title with
         None -> () |
         Some _ -> ps fmt "\\maketitle\n"
       );
-      if !Args.with_toc then ps fmt "\\tableofcontents\n";
+      if !Global.with_toc then ps fmt "\\tableofcontents\n";
       (
        let info = Odoc_info.apply_opt
            (Odoc_info.info_of_comment_file module_list)
-           !Odoc_info.Args.intro_file
+           !Odoc_info.Global.intro_file
        in
        (match info with None -> () | Some _ -> ps fmt "\\vspace{0.2cm}");
        self#latex_of_info fmt info;
@@ -1109,7 +1163,7 @@ class latex =
     (** Generate the LaTeX style file, if it does not exists. *)
     method generate_style_file =
       try
-        let dir = Filename.dirname !Args.out_file in
+        let dir = Filename.dirname !Global.out_file in
         let file = Filename.concat dir "ocamldoc.sty" in
         if Sys.file_exists file then
           Odoc_info.verbose (Odoc_messages.file_exists_dont_generate file)
@@ -1126,12 +1180,12 @@ class latex =
           prerr_endline s ;
           incr Odoc_info.errors ;
 
-    (** Generate the LaTeX file from a module list, in the {!Odoc_info.Args.out_file} file. *)
+    (** Generate the LaTeX file from a module list, in the {!Odoc_info.Global.out_file} file. *)
     method generate module_list =
       self#generate_style_file ;
-      let main_file = !Args.out_file in
+      let main_file = !Global.out_file in
       let dir = Filename.dirname main_file in
-      if !Args.separate_files then
+      if !separate_files then
         (
          let f m =
            try
@@ -1154,16 +1208,16 @@ class latex =
       try
         let chanout = open_out main_file in
         let fmt = Format.formatter_of_out_channel chanout in
-        if !Args.with_header then self#latex_header fmt module_list;
+        if !Global.with_header then self#latex_header fmt module_list;
         List.iter
           (fun m ->
-            if !Args.separate_files then
+            if !separate_files then
               ps fmt ("\\input{"^((Name.simple m.m_name))^".tex}\n")
             else
               self#generate_for_top_module fmt m
           )
           module_list ;
-        if !Args.with_trailer then ps fmt "\\end{document}";
+        if !Global.with_trailer then ps fmt "\\end{document}";
         Format.pp_print_flush fmt ();
         close_out chanout
       with
@@ -1172,3 +1226,6 @@ class latex =
           prerr_endline s ;
           incr Odoc_info.errors
   end
+end
+
+module type Latex_generator = module type of Generator

diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll
index 7b34b36424d969c139634383f392d0019ff1ca89..318a839fff18aac2206511a3648c7cb5acc4e916 100644 (file)
--- a/ocamldoc/odoc_lexer.mll
+++ b/ocamldoc/odoc_lexer.mll
@@ -178,7 +178,7 @@ and special_comment = parse
            let s2 = lecture_string () in
            let s3 = remove_blanks s2 in
            let s4 =
-             if !Odoc_args.remove_stars then
+             if !Odoc_global.remove_stars then
                remove_stars s3
              else
                s3
@@ -244,14 +244,14 @@ and special_comment_part2 = parse
         if !comments_level = 1 then
           (* finally we return the description we kept *)
           let desc =
-            if !Odoc_args.remove_stars then
+            if !Odoc_global.remove_stars then
               remove_stars !description
              else
               !description
           in
           let remain = lecture_string () in
           let remain2 =
-            if !Odoc_args.remove_stars then
+            if !Odoc_global.remove_stars then
               remove_stars remain
              else
                remain
@@ -322,7 +322,7 @@ and elements = parse
          | "return" ->
              T_RETURN
          | s ->
-             if !Odoc_args.no_custom_tags then
+             if !Odoc_global.no_custom_tags then
                raise (Failure (Odoc_messages.not_a_valid_tag s))
              else
                T_CUSTOM s

diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml
index eb6ec4d7d0130760c97dede01727f1b5cc04002f..dae2ff986abfa8cf860ede2f83967a62c4c7da25 100644 (file)
--- a/ocamldoc/odoc_man.ml
+++ b/ocamldoc/odoc_man.ml
@@ -21,6 +21,11 @@ open Class
 open Module
 open Search
 
+let man_suffix = ref Odoc_messages.default_man_suffix
+let man_section = ref Odoc_messages.default_man_section
+
+let man_mini = ref false
+
 let new_buf () = Buffer.create 1024
 let bp = Printf.bprintf
 let bs = Buffer.add_string
@@ -202,6 +207,9 @@ class virtual info =
           self#man_of_custom b info.M.i_custom
   end
 
+module Generator =
+struct
+
 (** This class is used to create objects which can generate a simple html documentation. *)
 class man =
   let re_slash = Str.regexp_string "/" in
@@ -210,7 +218,7 @@ class man =
 
     (** Get a file name from a complete name. *)
     method file_name name =
-      let s = Printf.sprintf "%s.%s" name !Args.man_suffix in
+      let s = Printf.sprintf "%s.%s" name !man_suffix in
       Str.global_replace re_slash "slash" s
 
     (** Escape special sequences of characters in a string. *)
@@ -229,7 +237,7 @@ class man =
 
     (** Open a file for output. Add the target directory.*)
     method open_out file =
-      let f = Filename.concat !Args.target_dir file in
+      let f = Filename.concat !Global.target_dir file in
       open_out f
 
     (** Print groff string for a text, without correction of blanks. *)
@@ -453,23 +461,49 @@ class man =
             (fun constr ->
               bs b ("| "^constr.vc_name);
               (
-               match constr.vc_args, constr.vc_text with
-                 [], None -> bs b "\n "
-               | [], (Some t) ->
+               match constr.vc_args, constr.vc_text,constr.vc_ret with
+               | [], None, None -> bs b "\n "
+               | [], (Some t), None ->
                    bs b "  (* ";
                    self#man_of_text b t;
                    bs b " *)\n "
-               | l, None ->
+               | l, None, None ->
                    bs b "\n.B of ";
                    self#man_of_type_expr_list ~par: false b father " * " l;
                    bs b " "
-               | l, (Some t) ->
+               | l, (Some t), None ->
                    bs b "\n.B of ";
                    self#man_of_type_expr_list ~par: false b father " * " l;
                    bs b ".I \"  \"\n";
                    bs b "(* ";
                    self#man_of_text b t;
                    bs b " *)\n "
+               | [], None, Some r ->
+                   bs b "\n.B : ";
+                   self#man_of_type_expr b father r;
+                   bs b " "
+               | [], (Some t), Some r ->
+                   bs b "\n.B : ";
+                   self#man_of_type_expr b father r;
+                   bs b ".I \"  \"\n";
+                   bs b "(* ";
+                   self#man_of_text b t;
+                   bs b " *)\n "
+               | l, None, Some r ->
+                   bs b "\n.B : ";
+                   self#man_of_type_expr_list ~par: false b father " * " l;
+                  bs b ".B -> ";
+                   self#man_of_type_expr b father r;
+                   bs b " "
+               | l, (Some t), Some r ->
+                   bs b "\n.B of ";
+                   self#man_of_type_expr_list ~par: false b father " * " l;
+                  bs b ".B -> ";
+                   self#man_of_type_expr b father r;
+                   bs b ".I \"  \"\n";
+                   bs b "(* ";
+                   self#man_of_text b t;
+                   bs b " *)\n "
               )
             )
             l
@@ -693,10 +727,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^cl.cl_name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
         let abstract =
           match cl.cl_info with
@@ -752,10 +786,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^ct.clt_name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
         let abstract =
           match ct.clt_info with
@@ -809,10 +843,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^mt.mt_name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
         let abstract =
           match mt.mt_info with
@@ -887,10 +921,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^m.m_name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
 
         let abstract =
           match m.m_info with
@@ -965,6 +999,8 @@ class man =
         | Res_attribute a -> Name.simple a.att_value.val_name
         | Res_method m -> Name.simple m.met_value.val_name
         | Res_section _ -> assert false
+        | Res_recfield (_,f) -> f.rf_name
+        | Res_const (_,f) -> f.vc_name
       in
       let all_items_pre = Odoc_info.Search.search_by_name module_list (Str.regexp ".*")  in
       let all_items = List.filter
@@ -1006,6 +1042,8 @@ class man =
           | Res_attribute a -> a.att_value.val_name
           | Res_method m -> m.met_value.val_name
           | Res_section (s,_) -> s
+          | Res_recfield (_,f) -> f.rf_name
+          | Res_const (_,f) -> f.vc_name
          )
      in
      let date = Unix.time () in
@@ -1014,10 +1052,10 @@ class man =
         let chanout = self#open_out file in
         let b = new_buf () in
         bs b (".TH \""^name^"\" ");
-        bs b !Odoc_args.man_section ;
+        bs b !man_section ;
         bs b (" "^(Odoc_misc.string_of_date ~hour: false date)^" ");
         bs b "OCamldoc ";
-        bs b ("\""^(match !Args.title with Some t -> t | None -> "")^"\"\n");
+        bs b ("\""^(match !Global.title with Some t -> t | None -> "")^"\"\n");
         bs b ".SH NAME\n";
         bs b (name^" \\- all "^name^" elements\n\n");
 
@@ -1069,10 +1107,13 @@ class man =
         | [Res_class cl] -> self#generate_for_class cl
         | [Res_class_type ct] -> self#generate_for_class_type ct
         | l ->
-            if !Args.man_mini then
+            if !man_mini then
               ()
             else
               self#generate_for_group l
       in
       List.iter f groups
   end
+end
+
+module type Man_generator = module type of Generator

diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml
index 7e81159b5294dd8dd191590e34384632faf9731a..4c6b452c7642f1b7f7b8011a50685036c731ea58 100644 (file)
--- a/ocamldoc/odoc_merge.ml
+++ b/ocamldoc/odoc_merge.ml
@@ -253,7 +253,7 @@ let merge_types merge_options mli ml =
           cons.vc_text <- new_desc
         with
           Not_found ->
-            if !Odoc_args.inverse_merge_ml_mli then
+            if !Odoc_global.inverse_merge_ml_mli then
               ()
             else
               raise (Failure (Odoc_messages.different_types mli.ty_name))
@@ -281,7 +281,7 @@ let merge_types merge_options mli ml =
           record.rf_text <- new_desc
         with
           Not_found ->
-            if !Odoc_args.inverse_merge_ml_mli then
+            if !Odoc_global.inverse_merge_ml_mli then
               ()
             else
               raise (Failure (Odoc_messages.different_types mli.ty_name))
@@ -289,7 +289,7 @@ let merge_types merge_options mli ml =
       List.iter f l1
 
   | _ ->
-      if !Odoc_args.inverse_merge_ml_mli then
+      if !Odoc_global.inverse_merge_ml_mli then
         ()
       else
         raise (Failure (Odoc_messages.different_types mli.ty_name))
@@ -357,7 +357,7 @@ let merge_classes merge_options mli ml =
                      a.att_value.val_info <- merge_info_opt merge_options
                          a.att_value.val_info a2.att_value.val_info;
                      a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ;
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        a.att_value.val_code <- a2.att_value.val_code;
                      true
                     )
@@ -396,7 +396,7 @@ let merge_classes merge_options mli ml =
                         parameters because the associated comment of a parameter may have been changed by the merge.*)
                      Odoc_value.update_value_parameters_text m.met_value;
 
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        m.met_value.val_code <- m2.met_value.val_code;
 
                      true
@@ -434,7 +434,7 @@ let merge_class_types merge_options mli ml =
                      a.att_value.val_info <- merge_info_opt merge_options
                          a.att_value.val_info a2.att_value.val_info;
                      a.att_value.val_loc <- { a.att_value.val_loc with loc_impl = a2.att_value.val_loc.loc_impl } ;
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        a.att_value.val_code <- a2.att_value.val_code;
 
                      true
@@ -473,7 +473,7 @@ let merge_class_types merge_options mli ml =
                         parameters because the associated comment of a parameter may have been changed y the merge.*)
                      Odoc_value.update_value_parameters_text m.met_value;
 
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        m.met_value.val_code <- m2.met_value.val_code;
 
                      true
@@ -637,7 +637,7 @@ let rec merge_module_types merge_options mli ml =
                         parameters because the associated comment of a parameter may have been changed y the merge.*)
                      Odoc_value.update_value_parameters_text v;
 
-                     if !Odoc_args.keep_code then
+                     if !Odoc_global.keep_code then
                        v.val_code <- v2.val_code;
 
                      true
@@ -727,7 +727,7 @@ and merge_modules merge_options mli ml =
   mli.m_top_deps <- remove_doubles mli.m_top_deps ml.m_top_deps ;
 
   let code =
-    if !Odoc_args.keep_code then
+    if !Odoc_global.keep_code then
       match mli.m_code, ml.m_code with
         Some s, _ -> Some s
       | _, Some s -> Some s
@@ -736,7 +736,7 @@ and merge_modules merge_options mli ml =
       None
   in
   let code_intf =
-    if !Odoc_args.keep_code then
+    if !Odoc_global.keep_code then
       match mli.m_code_intf, ml.m_code_intf with
         Some s, _ -> Some s
       | _, Some s -> Some s
@@ -883,7 +883,7 @@ and merge_modules merge_options mli ml =
                     parameters because the associated comment of a parameter may have been changed y the merge.*)
                  Odoc_value.update_value_parameters_text v;
 
-                 if !Odoc_args.keep_code then
+                 if !Odoc_global.keep_code then
                    v.val_code <- v2.val_code;
                  true
                 )
@@ -975,19 +975,19 @@ let merge merge_options modules_list =
             (
              (* we can merge m with m2 if there is an implementation
                 and an interface.*)
-             let f b = if !Odoc_args.inverse_merge_ml_mli then not b else b in
+             let f b = if !Odoc_global.inverse_merge_ml_mli then not b else b in
              match f m.m_is_interface, f m2.m_is_interface with
                true, false -> (merge_modules merge_options m m2) :: (iter l_others)
              | false, true -> (merge_modules merge_options m2 m) :: (iter l_others)
              | false, false ->
-                 if !Odoc_args.inverse_merge_ml_mli then
+                 if !Odoc_global.inverse_merge_ml_mli then
                    (* two Module.ts for the .mli ! *)
                    raise (Failure (Odoc_messages.two_interfaces m.m_name))
                  else
                    (* two Module.t for the .ml ! *)
                    raise (Failure (Odoc_messages.two_implementations m.m_name))
              | true, true ->
-                 if !Odoc_args.inverse_merge_ml_mli then
+                 if !Odoc_global.inverse_merge_ml_mli then
                    (* two Module.t for the .ml ! *)
                    raise (Failure (Odoc_messages.two_implementations m.m_name))
                  else

diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli
index 4f580ee8994f3b062412ecf7782b55f3c722f3c4..3133c5e939b8b1facb2f3e87b0571f8ce2033da8 100644 (file)
--- a/ocamldoc/odoc_merge.mli
+++ b/ocamldoc/odoc_merge.mli
@@ -13,7 +13,7 @@
 
 (** Merge of information from [.ml] and [.mli] for a module.*)
 
-(** Merging \@before tags. *)
+(** Merging \@before tags. *)
 val merge_before_tags :
     (string * Odoc_types.text) list -> (string * Odoc_types.text) list
 

diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml
index 18a1cb4bdcfef027a084dcfcd04578ebd449ea9a..7dfdff49071b15a53833ca44cd94595bc3b124a3 100644 (file)
--- a/ocamldoc/odoc_messages.ml
+++ b/ocamldoc/odoc_messages.ml
@@ -127,6 +127,11 @@ let latex_type_prefix =
   "<string>\n\t\tUse <string> as prefix for the LaTeX labels of types.\n"^
   "\t\t(default is \""^default_latex_type_prefix^"\")"
 
+let default_latex_type_elt_prefix = "typeelt:"
+let latex_type_elt_prefix =
+  "<string>\n\t\tUse <string> as prefix for the LaTeX labels of type elements.\n"^
+  "\t\t(default is \""^default_latex_type_elt_prefix^"\")"
+
 let default_latex_exception_prefix = "exception:"
 let latex_exception_prefix =
   "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^
@@ -218,9 +223,6 @@ let help = "\t\tDisplay this list of options"
 (** Error and warning messages *)
 
 let warning = "Warning"
-let pwarning s =
-  if !Odoc_config.print_warnings then prerr_endline (warning^": "^s);
-  if !Odoc_global.warn_error then incr Odoc_global.errors
 
 let bad_magic_number =
   "Bad magic number for this ocamldoc dump!\n"^
@@ -247,7 +249,7 @@ let tag_not_handled tag = "Tag @"^tag^" not handled by this generator"
 let bad_tree = "Incorrect tree structure."
 let not_a_valid_tag s = s^" is not a valid tag."
 let fun_without_param f = "Function "^f^" has no parameter.";;
-let method_without_param f = "Méthode "^f^" has no parameter.";;
+let method_without_param f = "Method "^f^" has no parameter.";;
 let anonymous_parameters f = "Function "^f^" has anonymous parameters."
 let function_colon f = "Function "^f^": "
 let implicit_match_in_parameter = "Parameters contain implicit pattern matching."
@@ -297,11 +299,17 @@ let cross_attribute_not_found n = "Attribute "^n^" not found"
 let cross_section_not_found n = "Section "^n^" not found"
 let cross_value_not_found n = "Value "^n^" not found"
 let cross_type_not_found n = "Type "^n^" not found"
+let cross_recfield_not_found n = Printf.sprintf "Record field %s not found" n
+let cross_const_not_found n = Printf.sprintf "Constructor %s not found" n
 
 let object_end = "object ... end"
 let struct_end = "struct ... end"
 let sig_end = "sig ... end"
 
+let current_generator_is_not kind =
+  Printf.sprintf "Current generator is not a %s generator" kind
+;;
+
 (** Messages for verbose mode. *)
 
 let analysing f = "Analysing file "^f^"..."

diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml
index c439ef31636ece02f516ed7ed471727984bbbeb2..c74b287d6f0b43fa2f945060b62bf63c4f060406 100644 (file)
--- a/ocamldoc/odoc_misc.ml
+++ b/ocamldoc/odoc_misc.ml
@@ -334,7 +334,7 @@ let rec get_before_dot s =
     let len = String.length s in
     let n = String.index s '.' in
     if n + 1 >= len then
-      (* le point est le dernier caractère *)
+      (* le point est le dernier caractère *)
       (true, s, "")
     else
       match s.[n+1] with
@@ -478,8 +478,8 @@ let remove_option typ =
     match t with
     | Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc
     | Types.Tconstr _
-    | Types.Tvar
-    | Types.Tunivar
+    | Types.Tvar _
+    | Types.Tunivar _
     | Types.Tpoly _
     | Types.Tarrow _
     | Types.Ttuple _

diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml
index 5cc8e038c7c6e26477e3a37049673296e52ecc25..88e3495754ecc51bbd393608c0ebd4795c6946f7 100644 (file)
--- a/ocamldoc/odoc_print.ml
+++ b/ocamldoc/odoc_print.ml
@@ -82,7 +82,7 @@ let simpl_class_type t =
     match t with
       Types.Tcty_constr (p,texp_list,ct) -> t
     | Types.Tcty_signature cs ->
-        (* on vire les vals et methods pour ne pas qu'elles soient imprimées
+        (* on vire les vals et methods pour ne pas qu'elles soient imprimées
            quand on affichera le type *)
         let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in
         Types.Tcty_signature { Types.cty_self = { cs.Types.cty_self with

diff --git a/ocamldoc/odoc_scan.ml b/ocamldoc/odoc_scan.ml
index 29e1ca2724fcc2475fcc9b42f82483089fa797e4..18a8f117c2d6a77d8cd105b0e73278e4c73e979d 100644 (file)
--- a/ocamldoc/odoc_scan.ml
+++ b/ocamldoc/odoc_scan.ml
@@ -28,7 +28,18 @@ class scanner =
   (** Scan of 'leaf elements'. *)
 
     method scan_value (v : Odoc_value.t_value) = ()
-    method scan_type (t : Odoc_type.t_type) = ()
+
+    method scan_type_pre (t : Odoc_type.t_type) = true
+
+    method scan_type_recfield t (f : Odoc_type.record_field) = ()
+    method scan_type_const t (f : Odoc_type.variant_constructor) = ()
+    method scan_type (t : Odoc_type.t_type) =
+      if self#scan_type_pre t then
+        match t.Odoc_type.ty_kind with
+          Odoc_type.Type_abstract -> ()
+        | Odoc_type.Type_variant l -> List.iter (self#scan_type_const t) l
+        | Odoc_type.Type_record l -> List.iter (self#scan_type_recfield t) l
+
     method scan_exception (e : Odoc_exception.t_exception) = ()
     method scan_attribute (a : Odoc_value.t_attribute) = ()
     method scan_method (m : Odoc_value.t_method) = ()
@@ -45,7 +56,7 @@ class scanner =
     method scan_class_pre (c : Odoc_class.t_class) = true
 
     (** This method scan the elements of the given class.
-       A VOIR : scan des classes héritées.*)
+       A VOIR : scan des classes héritées.*)
     method scan_class_elements c =
       List.iter
         (fun ele ->
@@ -71,7 +82,7 @@ class scanner =
     method scan_class_type_pre (ct : Odoc_class.t_class_type) = true
 
     (** This method scan the elements of the given class type.
-       A VOIR : scan des classes héritées.*)
+       A VOIR : scan des classes héritées.*)
     method scan_class_type_elements ct =
       List.iter
         (fun ele ->

diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml
index 65d602d3b9c86e3f54d55c3f388f88521b54aa51..91b1d13c899281214475306c8cf32684170c990a 100644 (file)
--- a/ocamldoc/odoc_search.ml
+++ b/ocamldoc/odoc_search.ml
@@ -32,6 +32,8 @@ type result_element =
   | Res_attribute of t_attribute
   | Res_method of t_method
   | Res_section of string * Odoc_types.text
+  | Res_recfield of t_type * record_field
+  | Res_const of t_type * variant_constructor
 
 type result = result_element list
 
@@ -43,7 +45,9 @@ module type Predicates =
     val p_class : t_class -> t -> bool * bool
     val p_class_type : t_class_type -> t -> bool * bool
     val p_value : t_value -> t -> bool
-    val p_type : t_type -> t -> bool
+    val p_recfield : t_type -> record_field -> t -> bool
+    val p_const : t_type -> variant_constructor -> t -> bool
+    val p_type : t_type -> t -> (bool * bool)
     val p_exception : t_exception -> t -> bool
     val p_attribute : t_attribute -> t -> bool
     val p_method : t_method -> t -> bool
@@ -92,7 +96,26 @@ module Search =
 
     let search_value va v = if P.p_value va v then [Res_value va] else []
 
-    let search_type t v = if P.p_type t v then [Res_type t] else []
+    let search_recfield t f v =
+      if P.p_recfield t f v then [Res_recfield (t,f)] else []
+
+    let search_const t f v =
+      if P.p_const t f v then [Res_const (t,f)] else []
+
+    let search_type t v =
+      let (go_deeper, ok) = P.p_type t v in
+      let l =
+        match go_deeper with
+          false -> []
+        | true ->
+            match t.ty_kind with
+              Type_abstract -> []
+            | Type_record l ->
+                List.flatten (List.map (fun rf -> search_recfield t rf v) l)
+            | Type_variant l ->
+                List.flatten (List.map (fun rf -> search_const t rf v) l)
+      in
+      if ok then (Res_type t) :: l else l
 
     let search_exception e v = if P.p_exception e v then [Res_exception e] else []
 
@@ -305,7 +328,13 @@ module P_name =
     let p_class c r = (true, c.cl_name =~ r)
     let p_class_type ct r = (true, ct.clt_name =~ r)
     let p_value v r = v.val_name =~ r
-    let p_type t r = t.ty_name =~ r
+    let p_recfield t f r =
+      let name = Printf.sprintf "%s.%s" t.ty_name f.rf_name in
+      name =~ r
+    let p_const t f r =
+      let name = Printf.sprintf "%s.%s" t.ty_name f.vc_name in
+      name =~ r
+    let p_type t r = (true, t.ty_name =~ r)
     let p_exception e r = e.ex_name =~ r
     let p_attribute a r = a.att_value.val_name =~ r
     let p_method m r = m.met_value.val_name =~ r
@@ -322,7 +351,9 @@ module P_values =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = true
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -347,7 +378,9 @@ module P_exceptions =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = true
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -372,7 +405,9 @@ module P_types =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = true
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, true)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -397,7 +432,9 @@ module P_attributes =
     let p_class _ _ = (true, false)
     let p_class_type _ _ = (true, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = true
     let p_method _ _ = false
@@ -422,7 +459,9 @@ module P_methods =
     let p_class _ _ = (true, false)
     let p_class_type _ _ = (true, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = true
@@ -447,7 +486,9 @@ module P_classes =
     let p_class _ _ = (false, true)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -472,7 +513,9 @@ module P_class_types =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, true)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -497,7 +540,9 @@ module P_modules =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false
@@ -522,7 +567,9 @@ module P_module_types =
     let p_class _ _ = (false, false)
     let p_class_type _ _ = (false, false)
     let p_value _ _ = false
-    let p_type _ _ = false
+    let p_recfield _ _ _ = false
+    let p_const _ _ _ = false
+    let p_type _ _ = (false, false)
     let p_exception _ _ = false
     let p_attribute _ _ = false
     let p_method _ _ = false

diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli
index d7ace5831afcffcd74a44b43eadc84c5a3fc71c1..2f882d52461c3d773fdb5e714c8117ded76c696f 100644 (file)
--- a/ocamldoc/odoc_search.mli
+++ b/ocamldoc/odoc_search.mli
@@ -25,6 +25,8 @@ type result_element =
   | Res_attribute of Odoc_value.t_attribute
   | Res_method of Odoc_value.t_method
   | Res_section of string * Odoc_types.text
+  | Res_recfield of  Odoc_type.t_type * Odoc_type.record_field
+  | Res_const of  Odoc_type.t_type * Odoc_type.variant_constructor
 
 (** The type representing a research result.*)
 type result = result_element list
@@ -42,7 +44,9 @@ module type Predicates =
     val p_class : Odoc_class.t_class -> t -> bool * bool
     val p_class_type : Odoc_class.t_class_type -> t -> bool * bool
     val p_value : Odoc_value.t_value -> t -> bool
-    val p_type : Odoc_type.t_type -> t -> bool
+    val p_recfield : Odoc_type.t_type -> Odoc_type.record_field -> t -> bool
+    val p_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> t -> bool
+    val p_type : Odoc_type.t_type -> t -> (bool * bool)
     val p_exception : Odoc_exception.t_exception -> t -> bool
     val p_attribute : Odoc_value.t_attribute -> t -> bool
     val p_method : Odoc_value.t_method -> t -> bool
@@ -59,6 +63,14 @@ module Search :
       (** search in a value *)
       val search_value : Odoc_value.t_value -> P.t -> result_element list
 
+      (** search in a record field *)
+      val search_recfield :
+        Odoc_type.t_type -> Odoc_type.record_field -> P.t -> result_element list
+
+      (** search in a variant constructor *)
+      val search_const :
+        Odoc_type.t_type -> Odoc_type.variant_constructor -> P.t -> result_element list
+
       (** search in a type *)
       val search_type : Odoc_type.t_type -> P.t -> result_element list
 
@@ -102,7 +114,9 @@ module P_name :
     val p_class : Odoc_class.t_class -> Str.regexp -> bool * bool
     val p_class_type : Odoc_class.t_class_type -> Str.regexp -> bool * bool
     val p_value : Odoc_value.t_value -> Str.regexp -> bool
-    val p_type : Odoc_type.t_type -> Str.regexp -> bool
+    val p_recfield : Odoc_type.t_type -> Odoc_type.record_field -> Str.regexp -> bool
+    val p_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> Str.regexp -> bool
+    val p_type : Odoc_type.t_type -> Str.regexp -> (bool * bool)
     val p_exception : Odoc_exception.t_exception -> Str.regexp -> bool
     val p_attribute : Odoc_value.t_attribute -> Str.regexp -> bool
     val p_method : Odoc_value.t_method -> Str.regexp -> bool
@@ -113,6 +127,8 @@ module Search_by_name :
   sig
     val search_section : Odoc_types.text -> string -> P_name.t -> result_element list
     val search_value : Odoc_value.t_value -> P_name.t -> result_element list
+    val search_recfield : Odoc_type.t_type -> Odoc_type.record_field -> P_name.t -> result_element list
+    val search_const : Odoc_type.t_type -> Odoc_type.variant_constructor -> P_name.t -> result_element list
     val search_type : Odoc_type.t_type -> P_name.t -> result_element list
     val search_exception :
       Odoc_exception.t_exception -> P_name.t -> result_element list

diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 34a71e84e9d5d1cfa9c5e7db547db6b7077914c4..75845bc67b1dab93b7ca220efd91e7bdc8ab679a 100644 (file)
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -179,21 +179,21 @@ module Analyser =
             match cons_core_type_list_list with
               [] ->
                 (0, acc)
-            | (name, core_type_list, loc) :: [] ->
+            | (name, _, _, loc) :: [] ->
                 let s = get_string_of_file
                     loc.Location.loc_end.Lexing.pos_cnum
                     pos_limit
                 in
                 let (len, comment_opt) =  My_ir.just_after_special !file_name s in
                 (len, acc @ [ (name, comment_opt) ])
-            | (name, core_type_list, loc) :: (name2, core_type_list2, loc2)
+            | (name, _, _, loc) :: (name2, core_type_list2, ret_type2, loc2)
               :: q ->
                 let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in
                 let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in
                 let s = get_string_of_file pos_end_first pos_start_second in
                 let (_,comment_opt) = My_ir.just_after_special !file_name  s in
                 f (acc @ [name, comment_opt])
-                  ((name2, core_type_list2, loc2) :: q)
+                  ((name2, core_type_list2, ret_type2, loc2) :: q)
           in
           f [] cons_core_type_list_list
 
@@ -219,9 +219,8 @@ module Analyser =
       match type_kind with
         Types.Type_abstract ->
           Odoc_type.Type_abstract
-
       | Types.Type_variant l ->
-          let f (constructor_name, type_expr_list) =
+          let f (constructor_name, type_expr_list, ret_type) =
             let comment_opt =
               try
                 match List.assoc constructor_name name_comment_list with
@@ -232,6 +231,7 @@ module Analyser =
             {
               vc_name = constructor_name ;
               vc_args = List.map (Odoc_env.subst_type env) type_expr_list ;
+             vc_ret =  may_map (Odoc_env.subst_type env) ret_type;
               vc_text = comment_opt
             }
           in
@@ -524,12 +524,12 @@ module Analyser =
               {
                 ex_name = Name.concat current_module_name name ;
                 ex_info = comment_opt ;
-                ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ;
+                ex_args = List.map (Odoc_env.subst_type env) types_excep_decl.exn_args ;
                 ex_alias = None ;
                 ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ;
                 ex_code =
                    (
-                    if !Odoc_args.keep_code then
+                    if !Odoc_global.keep_code then
                       Some (get_string_of_file pos_start_ele pos_end_ele)
                     else
                       None
@@ -617,7 +617,7 @@ module Analyser =
                       };
                       ty_code =
                         (
-                         if !Odoc_args.keep_code then
+                         if !Odoc_global.keep_code then
                            Some (get_string_of_file loc_start new_end)
                          else
                            None
@@ -660,7 +660,7 @@ module Analyser =
             in
             let module_kind = analyse_module_kind env complete_name module_type sig_module_type in
             let code_intf =
-              if !Odoc_args.keep_code then
+              if !Odoc_global.keep_code then
                 let loc = module_type.Parsetree.pmty_loc in
                 let st = loc.Location.loc_start.Lexing.pos_cnum in
                 let en = loc.Location.loc_end.Lexing.pos_cnum in
@@ -691,7 +691,7 @@ module Analyser =
             new_module.m_info <- merge_infos new_module.m_info info_after_opt ;
             let new_env = Odoc_env.add_module env new_module.m_name in
             let new_env2 =
-              match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
+              match new_module.m_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
                 Types.Tmty_signature s -> Odoc_env.add_signature new_env new_module.m_name ~rel: (Name.simple new_module.m_name) s
               | _ -> new_env
             in
@@ -711,7 +711,7 @@ module Analyser =
                       raise (Failure (Odoc_messages.module_not_found current_module_name name))
                   in
                   match sig_module_type with
-                    (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
+                    (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
                     Types.Tmty_signature s ->
                       Odoc_env.add_signature e complete_name ~rel: name s
                   | _ ->
@@ -751,7 +751,7 @@ module Analyser =
                   (* associate the comments to each constructor and build the [Type.t_type] *)
                   let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in
                   let code_intf =
-                    if !Odoc_args.keep_code then
+                    if !Odoc_global.keep_code then
                       let loc = modtype.Parsetree.pmty_loc in
                       let st = loc.Location.loc_start.Lexing.pos_cnum in
                       let en = loc.Location.loc_end.Lexing.pos_cnum in
@@ -826,7 +826,7 @@ module Analyser =
             mt.mt_info <- merge_infos mt.mt_info info_after_opt ;
             let new_env = Odoc_env.add_module_type env mt.mt_name in
             let new_env2 =
-              match sig_mtype with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
+              match sig_mtype with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *)
                 Some (Types.Tmty_signature s) -> Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s
               | _ -> new_env
             in
@@ -856,7 +856,7 @@ module Analyser =
                 im_info = comment_opt;
               }
             in
-            (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
+            (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *)
 
         | Parsetree.Psig_class class_description_list ->
             (* we start by extending the environment *)
@@ -1179,7 +1179,7 @@ module Analyser =
           ([], Class_structure (inher_l, ele))
 
       | (Parsetree.Pcty_fun (parse_label, _, pclass_type), Types.Tcty_fun (label, type_expr, class_type)) ->
-          (* label = string. Dans les signatures, pas de nom de paramètres à l'intérieur des tuples *)
+          (* label = string. Dans les signatures, pas de nom de paramètres à l'intérieur des tuples *)
           (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *)
           if parse_label = label then
             (
@@ -1195,7 +1195,7 @@ module Analyser =
             )
           else
             (
-             raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents")
+             raise (Failure "Parsetree.Pcty_fun (parse_label, _, pclass_type), labels différents")
             )
 
       | _ ->
@@ -1283,7 +1283,7 @@ module Analyser =
         analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast
       in
       let code_intf =
-        if !Odoc_args.keep_code then
+        if !Odoc_global.keep_code then
           Some !file
         else
           None

diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml
index b20cd8b4bcc32b12bacbf6888bc2b8dd9601bea6..d420c059712de08ade56e43ecd79cfafe257b0f7 100644 (file)
--- a/ocamldoc/odoc_str.ml
+++ b/ocamldoc/odoc_str.ml
@@ -31,7 +31,7 @@ let rec is_arrow_type t =
   | Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2
   | Types.Ttuple _
   | Types.Tconstr _
-  | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
+  | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
   | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
 
 let raw_string_of_type_list sep type_list =
@@ -43,7 +43,7 @@ let raw_string_of_type_list sep type_list =
     | Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2
     | Types.Tconstr _ ->
         false
-    | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
+    | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
     | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
   in
   let print_one_type variance t =
@@ -183,11 +183,20 @@ let string_of_type t =
          (List.map
             (fun cons ->
               "  | "^cons.M.vc_name^
-              (match cons.M.vc_args with
-                [] -> ""
-              | l ->
-                  " of "^(String.concat " * "
-                            (List.map (fun t -> "("^(Odoc_print.string_of_type_expr t)^")") l))
+              (match cons.M.vc_args,cons.M.vc_ret with
+              | [], None -> ""
+              | l, None ->
+                  " of " ^
+                  (String.concat " * "
+                     (List.map
+                        (fun t -> "("^Odoc_print.string_of_type_expr t^")") l))
+              | [], Some r -> " : " ^ Odoc_print.string_of_type_expr r
+              | l, Some r ->
+                  " : " ^
+                  (String.concat " * "
+                     (List.map
+                        (fun t -> "("^Odoc_print.string_of_type_expr t^")") l))
+                  ^ " -> " ^ Odoc_print.string_of_type_expr r
               )^
               (match cons.M.vc_text with
                 None ->
@@ -205,7 +214,8 @@ let string_of_type t =
          (List.map
             (fun record ->
               "   "^(if record.M.rf_mutable then "mutable " else "")^
-              record.M.rf_name^" : "^(Odoc_print.string_of_type_expr record.M.rf_type)^";"^
+              record.M.rf_name^" : "^
+              (Odoc_print.string_of_type_expr record.M.rf_type)^";"^
               (match record.M.rf_text with
                 None ->
                   ""

diff --git a/ocamldoc/odoc_test.ml b/ocamldoc/odoc_test.ml
index a9868f6ef1e73a87e39097dd54cadbd9c8660b4d..a903b1c151e5d8a44f884c3f780f96493861b2b0 100644 (file)
--- a/ocamldoc/odoc_test.ml
+++ b/ocamldoc/odoc_test.ml
@@ -22,10 +22,13 @@ type test_kind =
 
 let p = Format.fprintf
 
-class string_gen =
+module Generator (G : Odoc_gen.Base) =
+struct
+  class string_gen =
   object(self)
     inherit Odoc_info.Scan.scanner
 
+
     val mutable test_kinds = []
     val mutable fmt = Format.str_formatter
 
@@ -88,7 +91,7 @@ class string_gen =
       true
 
     method generate (module_list: Odoc_info.Module.t_module list) =
-      let oc = open_out !Odoc_info.Args.out_file in
+      let oc = open_out !Odoc_info.Global.out_file in
       fmt <- Format.formatter_of_out_channel oc;
       (
        try
@@ -106,7 +109,15 @@ class string_gen =
       close_out oc
   end
 
+  class generator =
+    let g = new string_gen in
+    object
+      inherit G.generator as base
+
+      method generate l =
+        base#generate l;
+        g#generate l
+    end
+end;;
 
-let my_generator = new string_gen
-let _ = Odoc_info.Args.set_doc_generator
-    (Some (my_generator :> Odoc_info.Args.doc_generator))
+let _ = Odoc_args.extend_base_generator (module Generator : Odoc_gen.Base_functor);;

diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml
index a853c4f7a49e3ecef0a81b9209b59089eb23f4ed..5c75b4fdfa9943205bbfef5c11b9530fa8c47fad 100644 (file)
--- a/ocamldoc/odoc_texi.ml
+++ b/ocamldoc/odoc_texi.ml
@@ -1,11 +1,12 @@
 (***********************************************************************)
-(*                           OCamldoc                                  *)
+(*                             OCamldoc                                *)
 (*                                                                     *)
 (*      Olivier Andrieu, base sur du code de Maxence Guesdon           *)
 (*                                                                     *)
 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
 (*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
 (***********************************************************************)
 
 (* $Id$ *)
@@ -20,6 +21,12 @@ open Exception
 open Class
 open Module
 
+let esc_8bits = ref false
+
+let info_section = ref "OCaml"
+
+let info_entry = ref []
+
 (** {2 Some small helper functions} *)
 
 let puts_nl chan s =
@@ -140,7 +147,7 @@ struct
     (Str.regexp "}", "@}") ;
     (Str.regexp "\\.\\.\\.", "@dots{}") ;
   ] @
-    (if !Args.esc_8bits
+    (if !esc_8bits
     then [
     (Str.regexp "à", "@`a") ;
     (Str.regexp "â", "@^a") ;
@@ -381,6 +388,9 @@ class text =
 
 exception Aliased_node
 
+module Generator =
+struct
+
 (** This class is used to create objects which can generate a simple
     Texinfo documentation. *)
 class texi =
@@ -413,7 +423,7 @@ class texi =
 
     method index (ind : indices) ent =
       Verbatim
-        (if !Args.with_index
+        (if !Global.with_index
         then (assert(List.mem ind indices_to_build) ;
               String.concat ""
                 [ "@" ; indices ind ; "index " ;
@@ -630,9 +640,13 @@ class texi =
           Printf.sprintf "(%s) "
             (String.concat ", " (List.map f l))
 
-    method string_of_type_args = function
-      | [] -> ""
-      | args -> " of " ^ (Odoc_info.string_of_type_list " * " args)
+    method string_of_type_args (args:Types.type_expr list) (ret:Types.type_expr option) = 
+      match args, ret with
+      | [], None -> ""
+      | args, None -> " of " ^ (Odoc_info.string_of_type_list " * " args)
+      | [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r)
+      | args, Some r -> " : " ^ (Odoc_info.string_of_type_list " * " args) ^ 
+                               " -> " ^ (Odoc_info.string_of_type_expr r)
 
     (** Return Texinfo code for a type. *)
     method texi_of_type ty =
@@ -658,11 +672,13 @@ class texi =
                   (List.map
                      (fun constr ->
                        (Raw ("  | " ^ constr.vc_name)) ::
-                       (Raw (self#string_of_type_args constr.vc_args)) ::
+                       (Raw (self#string_of_type_args
+                               constr.vc_args constr.vc_ret)) ::
                        (match constr.vc_text with
                        | None -> [ Newline ]
                        | Some t ->
-                           ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @
+                           (Raw (indent 5 "\n(* ") ::
+                            self#soft_fix_linebreaks 8 t) @
                            [ Raw " *)" ; Newline ]
                        ) ) l ) )
            | Type_record l ->
@@ -694,7 +710,7 @@ class texi =
         [ self#fixedblock
             ( [ Newline ; minus ; Raw "exception " ;
                 Raw (Name.simple e.ex_name) ;
-                Raw (self#string_of_type_args e.ex_args) ] @
+                Raw (self#string_of_type_args e.ex_args None) ] @
               (match e.ex_alias with
               | None -> []
               | Some ea -> [ Raw " = " ; Raw
@@ -1055,7 +1071,7 @@ class texi =
 
     (** Writes the header of the TeXinfo document. *)
     method generate_texi_header chan texi_filename m_list =
-      let title = match !Args.title with
+      let title = match !Global.title with
       | None -> ""
       | Some s -> self#escape s in
       let filename =
@@ -1080,18 +1096,18 @@ class texi =
                "@settitle " ^ title ;
                "@c %**end of header" ; ] ;
 
-             (if !Args.with_index then
+             (if !Global.with_index then
                List.map
                  (fun ind ->
                    "@defcodeindex " ^ (indices ind))
                  indices_to_build
              else []) ;
 
-             [ Texi.dirsection !Args.info_section ] ;
+             [ Texi.dirsection !info_section ] ;
 
              Texi.direntry
-               (if !Args.info_entry <> []
-               then !Args.info_entry
+               (if !info_entry <> []
+               then !info_entry
                else [ Printf.sprintf "* %s: (%s)."
                         title
                         (Filename.chop_suffix filename ".info") ]) ;
@@ -1108,7 +1124,7 @@ class texi =
 
       (* insert the intro file *)
       begin
-        match !Odoc_info.Args.intro_file with
+        match !Odoc_info.Global.intro_file with
         | None when title <> "" ->
             puts_nl chan "@ifinfo" ;
             puts_nl chan ("Documentation for " ^ title) ;
@@ -1125,7 +1141,7 @@ class texi =
       (* write a top menu *)
       Texi.generate_menu chan
         ((List.map (fun m -> `Module m) m_list) @
-         (if !Args.with_index then
+         (if !Global.with_index then
            let indices_names_to_build = List.map indices indices_to_build in
            List.rev
              (List.fold_left
@@ -1142,7 +1158,7 @@ class texi =
     (** Writes the trailer of the TeXinfo document. *)
     method generate_texi_trailer chan =
       nl chan ;
-      if !Args.with_index
+      if !Global.with_index
       then
         let indices_names_to_build = List.map indices indices_to_build in
         List.iter (puts_nl chan)
@@ -1155,7 +1171,7 @@ class texi =
                          "@printindex " ^ shortname ; ]
                   else [])
                 indices_names )) ;
-      if !Args.with_toc
+      if !Global.with_toc
       then puts_nl chan "@contents" ;
       puts_nl chan "@bye"
 
@@ -1203,25 +1219,25 @@ class texi =
 
 
     (** Generate the Texinfo file from a module list,
-       in the {!Odoc_info.Args.out_file} file. *)
+       in the {!Odoc_info.Global.out_file} file. *)
     method generate module_list =
       Hashtbl.clear node_tbl ;
       let filename =
-        if !Args.out_file = Odoc_messages.default_out_file
+        if !Global.out_file = Odoc_messages.default_out_file
         then "ocamldoc.texi"
-        else !Args.out_file in
-      if !Args.with_index
+        else !Global.out_file in
+      if !Global.with_index
       then List.iter self#scan_for_index
           (List.map (fun m -> `Module m) module_list) ;
       try
         let chanout = open_out
-            (Filename.concat !Args.target_dir filename) in
-        if !Args.with_header
+            (Filename.concat !Global.target_dir filename) in
+        if !Global.with_header
         then self#generate_texi_header chanout filename module_list ;
         List.iter
           (self#generate_for_module chanout)
           module_list ;
-        if !Args.with_trailer
+        if !Global.with_trailer
         then self#generate_texi_trailer chanout ;
         close_out chanout
       with
@@ -1230,3 +1246,6 @@ class texi =
           prerr_endline s ;
           incr Odoc_info.errors
   end
+end
+
+module type Texi_generator = module type of Generator

diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml
index b50a2dbd17f3bec0a3ae7113c47fa7c64d680ce8..e80b680ed4ded62f7f34af022e358f11073285aa 100644 (file)
--- a/ocamldoc/odoc_text.ml
+++ b/ocamldoc/odoc_text.ml
@@ -133,6 +133,8 @@ module Texter =
                    | RK_attribute -> "attribute"
                    | RK_method -> "method"
                    | RK_section _ -> "section"
+                   | RK_recfield -> "recfield"
+                   | RK_const -> "const"
                  in
                  s^":"
             )

diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll
index f229f08a66dd4195c634ef3fe8f192429203b060..a4888c1a8f0a3484a20c330c3f4283fac45dcd46 100644 (file)
--- a/ocamldoc/odoc_text_lexer.mll
+++ b/ocamldoc/odoc_text_lexer.mll
@@ -22,10 +22,10 @@ let char_number = ref 0
 
 let string_buffer = Buffer.create 32
 
-(** Fonction de remise à zéro de la chaine de caractères tampon *)
+(** Fonction de remise à zéro de la chaine de caractères tampon *)
 let reset_string_buffer () = Buffer.reset string_buffer
 
-(** Fonction d'ajout d'un caractère dans la chaine de caractères tampon *)
+(** Fonction d'ajout d'un caractère dans la chaine de caractères tampon *)
 let ajout_char_string = Buffer.add_char string_buffer
 
 (** Add a string to the buffer. *)
@@ -161,6 +161,8 @@ let begin_clt_ref = "{!classtype:"blank_nl | "{!classtype:"
 let begin_att_ref = "{!attribute:"blank_nl | "{!attribute:"
 let begin_met_ref = "{!method:"blank_nl | "{!method:"
 let begin_sec_ref = "{!section:"blank_nl | "{!section:"
+let begin_recf_ref = "{!recfield:"blank_nl | "{!recfield:"
+let begin_const_ref = "{!const:"blank_nl | "{!const:"
 let begin_mod_list_ref = "{!modules:"blank_nl | "{!modules:"
 let index_list = "{!indexlist}"
 let begin_custom = "{"['a'-'z''A'-'Z']['a'-'z''A'-'Z''0'-'9']*
@@ -664,7 +666,38 @@ rule main = parse
            Char (Lexing.lexeme lexbuf)
           )
     }
-
+| begin_recf_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           RECF_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
+| begin_const_ref
+    {
+      incr_cpts lexbuf ;
+      if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then
+        Char (Lexing.lexeme lexbuf)
+      else
+        if not !ele_ref_mode then
+          (
+           ele_ref_mode := true;
+           CONST_REF
+          )
+        else
+          (
+           Char (Lexing.lexeme lexbuf)
+          )
+    }
 | begin_mod_list_ref
     {
       incr_cpts lexbuf ;
@@ -720,7 +753,10 @@ rule main = parse
 | shortcut_list_item
     {
       incr_cpts lexbuf ;
-      if !shortcut_list_mode then
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode
+          || !ele_ref_mode || !verb_mode then
+        Char (Lexing.lexeme lexbuf)
+      else if !shortcut_list_mode then
         (
          SHORTCUT_LIST_ITEM
         )
@@ -734,7 +770,10 @@ rule main = parse
 | shortcut_enum_item
     {
       incr_cpts lexbuf ;
-      if !shortcut_list_mode then
+      if !target_mode || (!open_brackets >= 1) || !code_pre_mode
+         || !ele_ref_mode || !verb_mode then
+        Char (Lexing.lexeme lexbuf)
+      else if !shortcut_list_mode then
         SHORTCUT_ENUM_ITEM
       else
         (

diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly
index 478cfa074e9cbb91e80fc89ef60f43255f9ef82b..c9d301449fc23ccd3c2939b559453579588dbee4 100644 (file)
--- a/ocamldoc/odoc_text_parser.mly
+++ b/ocamldoc/odoc_text_parser.mly
@@ -62,6 +62,8 @@ let print_DEBUG s = print_string s; print_newline ()
 %token ATT_REF
 %token MET_REF
 %token SEC_REF
+%token RECF_REF
+%token CONST_REF
 %token MOD_LIST_REF
 %token INDEX_LIST
 
@@ -110,6 +112,8 @@ ele_ref_kind:
 | ATT_REF { Some RK_attribute }
 | MET_REF { Some RK_method }
 | SEC_REF { Some (RK_section [])}
+| RECF_REF { Some RK_recfield }
+| CONST_REF { Some RK_const }
 ;
 
 text_element:

diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml
index 9d19dc67d9e479f8482cb5e91d1a18b578037111..ee973a01d7c0d5db95c92b85b51bc3cc3ad23b70 100644 (file)
--- a/ocamldoc/odoc_type.ml
+++ b/ocamldoc/odoc_type.ml
@@ -22,6 +22,7 @@ type private_flag = Asttypes.private_flag =
 type variant_constructor = {
     vc_name : string ;
     vc_args : Types.type_expr list ; (** arguments of the constructor *)
+    vc_ret : Types.type_expr option ;
     mutable vc_text : Odoc_types.text option ; (** optional user description *)
   }
 

diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml
index 53a1ca5f9c4c73e4386295fe2871be741871668a..85bac555fd9209bf8387135aa1d6ece05b29e7cb 100644 (file)
--- a/ocamldoc/odoc_types.ml
+++ b/ocamldoc/odoc_types.ml
@@ -22,6 +22,8 @@ type ref_kind =
   | RK_attribute
   | RK_method
   | RK_section of text
+  | RK_recfield
+  | RK_const
 
 and text_element =
   | Raw of string

diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli
index d4affb5039f4a867d0d44b36a58f5d1d854c5963..124beba1b54db77f6b301716a4fcaec51845fcf8 100644 (file)
--- a/ocamldoc/odoc_types.mli
+++ b/ocamldoc/odoc_types.mli
@@ -25,6 +25,8 @@ type ref_kind =
   | RK_attribute
   | RK_method
   | RK_section of text
+  | RK_recfield
+  | RK_const
 
 and text_element =
   | Raw of string (** Raw text. *)

diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml
index a210f0851e10621ba8a0945b422e8ad5b046dd07..c8881ddfd8e767289caf95418777c1f716d805b4 100644 (file)
--- a/ocamldoc/odoc_value.ml
+++ b/ocamldoc/odoc_value.ml
@@ -77,13 +77,13 @@ let parameter_list_from_arrows typ =
     | Types.Tsubst texp ->
         iter texp
     | Types.Tpoly (texp, _) -> iter texp
-    | Types.Tvar
+    | Types.Tvar _
     | Types.Ttuple _
     | Types.Tconstr _
     | Types.Tobject _
     | Types.Tfield _
     | Types.Tnil
-    | Types.Tunivar
+    | Types.Tunivar _
     | Types.Tpackage _
     | Types.Tvariant _ ->
         []

diff --git a/ocamldoc/remove_DEBUG b/ocamldoc/remove_DEBUG
index 78b11e6128830b92942c099262fd5b0100a8d55b..b8550e252e7cb2436a8c5f8b6c5c6315ed4d29b9 100755 (executable)
--- a/ocamldoc/remove_DEBUG
+++ b/ocamldoc/remove_DEBUG
@@ -1,7 +1,7 @@
 #!/bin/sh
 
 #(***********************************************************************)
-#(*                            OCamldoc                                 *)
+#(*                             OCamldoc                                *)
 #(*                                                                     *)
 #(*            Damien Doligez, projet Moscova, INRIA Rocquencourt       *)
 #(*                                                                     *)

diff --git a/ocamldoc/runocamldoc b/ocamldoc/runocamldoc
index a71d705ccdd0a0b6e0d7dacfd73da7ee303f545c..3aba71923a14954fd0eccdc3c5c7771aec30e880 100644 (file)
--- a/ocamldoc/runocamldoc
+++ b/ocamldoc/runocamldoc
@@ -1,4 +1,17 @@
 #!/bin/sh
+
+#######################################################################
+#                                                                     #
+#                                OCaml                                #
+#                                                                     #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt         #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique.  All rights reserved.  This file is distributed    #
+#  under the terms of the Q Public License version 1.0.               #
+#                                                                     #
+#######################################################################
+
 # $Id$
 
 case "$1" in

diff --git a/otherlibs/Makefile b/otherlibs/Makefile
index c5db1981c152a55666d4d75ce25ee0daf87ec6d5..fba032df85bc09323e09bb01ae66283352a8a857 100644 (file)
--- a/otherlibs/Makefile
+++ b/otherlibs/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt
index 32aca21c06ded0e898c4d439d79aee92113f6071..ceab7f0c5945604b4dc5c44262d7fc79be3257ae 100644 (file)
--- a/otherlibs/Makefile.nt
+++ b/otherlibs/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared
index 7e6780b3ea43e1dfc159d92c5abb39062d681e11..08e9abb1d588e0b918c8ae0640b7060aaec5f46c 100644 (file)
--- a/otherlibs/Makefile.shared
+++ b/otherlibs/Makefile.shared
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/bigarray/.cvsignore b/otherlibs/bigarray/.cvsignore
deleted file mode 100644 (file)
index 52db225..0000000
--- a/otherlibs/bigarray/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-*.o
-*.x
-so_locations
-*.so
-*.a

diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend
index c70f81a5201bd4d68eca026abbf91e0c92406d20..889328a3336389931baff08cd9fbba36379ca0da 100644 (file)
--- a/otherlibs/bigarray/.depend
+++ b/otherlibs/bigarray/.depend
@@ -3,7 +3,7 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \
   ../../byterun/../config/s.h ../../byterun/mlvalues.h bigarray.h \
   ../../byterun/config.h ../../byterun/mlvalues.h ../../byterun/custom.h \
   ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \
-  ../../byterun/fix_code.h ../../byterun/memory.h ../../byterun/gc.h \
+  ../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h
 mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \
@@ -16,6 +16,6 @@ mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/config.h \
   ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \
   ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h \
   ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h
-bigarray.cmi:
-bigarray.cmo: bigarray.cmi
-bigarray.cmx: bigarray.cmi
+bigarray.cmi :
+bigarray.cmo : bigarray.cmi
+bigarray.cmx : bigarray.cmi

diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile
index 38914ff35aad0304c68d40346feb006ed26486d0..83b31525860b73897ba4a1f63e5a62a1de025c74 100644 (file)
--- a/otherlibs/bigarray/Makefile
+++ b/otherlibs/bigarray/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt
index 78f3fc6b676d6ba2e8d031de447bcd5566502504..e845ad62e0d75860e4894bd3753c683966411f69 100644 (file)
--- a/otherlibs/bigarray/Makefile.nt
+++ b/otherlibs/bigarray/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h
index 407a5377677bdd2ecbb25541a41a67ac5d27095b..f6552107a6b2301386d1a51e1aa53a1d6a9dfc04 100644 (file)
--- a/otherlibs/bigarray/bigarray.h
+++ b/otherlibs/bigarray/bigarray.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -42,7 +42,7 @@ enum caml_ba_kind {
   CAML_BA_UINT16,              /* Unsigned 16-bit integers */
   CAML_BA_INT32,               /* Signed 32-bit integers */
   CAML_BA_INT64,               /* Signed 64-bit integers */
-  CAML_BA_CAML_INT,            /* Caml-style integers (signed 31 or 63 bits) */
+  CAML_BA_CAML_INT,            /* OCaml-style integers (signed 31 or 63 bits) */
   CAML_BA_NATIVE_INT,       /* Platform-native long integers (32 or 64 bits) */
   CAML_BA_COMPLEX32,           /* Single-precision complex */
   CAML_BA_COMPLEX64,           /* Double-precision complex */
@@ -56,8 +56,8 @@ enum caml_ba_layout {
 };
 
 enum caml_ba_managed {
-  CAML_BA_EXTERNAL = 0,        /* Data is not allocated by Caml */
-  CAML_BA_MANAGED = 0x200,     /* Data is allocated by Caml */
+  CAML_BA_EXTERNAL = 0,        /* Data is not allocated by OCaml */
+  CAML_BA_MANAGED = 0x200,     /* Data is allocated by OCaml */
   CAML_BA_MAPPED_FILE = 0x400, /* Data is a memory mapped file */
   CAML_BA_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */
 };
@@ -73,7 +73,12 @@ struct caml_ba_array {
   intnat num_dims;            /* Number of dimensions */
   intnat flags;  /* Kind of element array + memory layout + allocation status */
   struct caml_ba_proxy * proxy; /* The proxy for sub-arrays, or NULL */
+  /* PR#5516: use C99's flexible array types if possible */
+#if (__STDC_VERSION__ >= 199901L)
+  intnat dim[]  /*[num_dims]*/; /* Size in each dimension */
+#else
   intnat dim[1] /*[num_dims]*/; /* Size in each dimension */
+#endif
 };
 
 #define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v))

diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml
index 09ae8bd13a71b2e1b4038ce823baca89bf05cc78..b9f22b18286e762877a4da0be0e58bc9213f9949 100644 (file)
--- a/otherlibs/bigarray/bigarray.ml
+++ b/otherlibs/bigarray/bigarray.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Manuel Serrano et Xavier Leroy, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -99,6 +99,8 @@ module Genarray = struct
                      = "caml_ba_map_file_bytecode" "caml_ba_map_file"
   let map_file fd ?(pos = 0L) kind layout shared dims =
     map_internal fd kind layout shared dims pos
+  external release: ('a, 'b, 'c) t -> unit
+     = "caml_ba_release"
 end
 
 module Array1 = struct
@@ -122,6 +124,8 @@ module Array1 = struct
     ba
   let map_file fd ?pos kind layout shared dim =
     Genarray.map_file fd ?pos kind layout shared [|dim|]
+  external release: ('a, 'b, 'c) t -> unit
+     = "caml_ba_release"
 end
 
 module Array2 = struct
@@ -161,6 +165,8 @@ module Array2 = struct
     ba
   let map_file fd ?pos kind layout shared dim1 dim2 =
     Genarray.map_file fd ?pos kind layout shared [|dim1;dim2|]
+  external release: ('a, 'b, 'c) t -> unit
+     = "caml_ba_release"
 end
 
 module Array3 = struct
@@ -210,6 +216,8 @@ module Array3 = struct
     ba
   let map_file fd ?pos kind layout shared dim1 dim2 dim3 =
     Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|]
+  external release: ('a, 'b, 'c) t -> unit
+     = "caml_ba_release"
 end
 
 external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t

diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli
index a49923ae212d6f60fa55258256a6b94ac219d992..73c27b575043c96707715418b4dd07277b5c6031 100644 (file)
--- a/otherlibs/bigarray/bigarray.mli
+++ b/otherlibs/bigarray/bigarray.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,13 +18,13 @@
    This module implements multi-dimensional arrays of integers and
    floating-point numbers, thereafter referred to as ``big arrays''.
    The implementation allows efficient sharing of large numerical
-   arrays between Caml code and C or Fortran numerical libraries.
+   arrays between OCaml code and C or Fortran numerical libraries.
 
    Concerning the naming conventions, users of this module are encouraged
    to do [open Bigarray] in their source, then refer to array types and
    operations via short dot notation, e.g. [Array1.t] or [Array2.sub].
 
-   Big arrays support all the Caml ad-hoc polymorphic operations:
+   Big arrays support all the OCaml ad-hoc polymorphic operations:
    - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare});
    - hashing (module [Hash]);
    - and structured input-output ({!Pervasives.output_value}
@@ -47,7 +47,7 @@
    ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}),
 - 16-bit integers (signed or unsigned)
    ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}),
-- Caml integers (signed, 31 bits on 32-bit architectures,
+- OCaml integers (signed, 31 bits on 32-bit architectures,
    63 bits on 64-bit architectures) ({!Bigarray.int_elt}),
 - 32-bit signed integer ({!Bigarray.int32_elt}),
 - 64-bit signed integers ({!Bigarray.int64_elt}),
@@ -72,20 +72,20 @@ type int64_elt
 type nativeint_elt
 
 type ('a, 'b) kind
-(** To each element kind is associated a Caml type, which is
-   the type of Caml values that can be stored in the big array
+(** To each element kind is associated an OCaml type, which is
+   the type of OCaml values that can be stored in the big array
    or read back from it.  This type is not necessarily the same
    as the type of the array elements proper: for instance,
    a big array whose elements are of kind [float32_elt] contains
    32-bit single precision floats, but reading or writing one of
-   its elements from Caml uses the Caml type [float], which is
+   its elements from OCaml uses the OCaml type [float], which is
    64-bit double precision floats.
 
    The abstract type [('a, 'b) kind] captures this association
-   of a Caml type ['a] for values read or written in the big array,
+   of an OCaml type ['a] for values read or written in the big array,
    and of an element kind ['b] which represents the actual contents
    of the big array.  The following predefined values of type
-   [kind] list all possible associations of Caml types with
+   [kind] list all possible associations of OCaml types with
    element kinds: *)
 
 val float32 : (float, float32_elt) kind
@@ -127,12 +127,12 @@ val nativeint : (nativeint, nativeint_elt) kind
 val char : (char, int8_unsigned_elt) kind
 (** As shown by the types of the values above,
    big arrays of kind [float32_elt] and [float64_elt] are
-   accessed using the Caml type [float].  Big arrays of complex kinds
-   [complex32_elt], [complex64_elt] are accessed with the Caml type
+   accessed using the OCaml type [float].  Big arrays of complex kinds
+   [complex32_elt], [complex64_elt] are accessed with the OCaml type
    {!Complex.t}.  Big arrays of
-   integer kinds are accessed using the smallest Caml integer
+   integer kinds are accessed using the smallest OCaml integer
    type large enough to represent the array elements:
-   [int] for 8- and 16-bit integer bigarrays, as well as Caml-integer
+   [int] for 8- and 16-bit integer bigarrays, as well as OCaml-integer
    bigarrays; [int32] for 32-bit integer bigarrays; [int64]
    for 64-bit integer bigarrays; and [nativeint] for
    platform-native integer bigarrays.  Finally, big arrays of
@@ -195,7 +195,7 @@ module Genarray :
 
      The three type parameters to [Genarray.t] identify the array element
      kind and layout, as follows:
-     - the first parameter, ['a], is the Caml type for accessing array
+     - the first parameter, ['a], is the OCaml type for accessing array
        elements ([float], [int], [int32], [int64], [nativeint]);
      - the second parameter, ['b], is the actual kind of array elements
        ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt],
@@ -206,7 +206,7 @@ module Genarray :
      For instance, [(float, float32_elt, fortran_layout) Genarray.t]
      is the type of generic big arrays containing 32-bit floats
      in Fortran layout; reads and writes in this array use the
-     Caml type [float]. *)
+     OCaml type [float]. *)
 
   external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
     = "caml_ba_create"
@@ -418,9 +418,35 @@ module Genarray :
      than the big array, only the initial portion of the file is
      mapped to the big array.  If the file is smaller than the big
      array, the file is automatically grown to the size of the big array.
-     This requires write permissions on [fd]. *)
+     This requires write permissions on [fd].
+
+     Array accesses are bounds-checked, but the bounds are determined by
+     the initial call to [map_file]. Therefore, you should make sure no
+     other process modifies the mapped file while you're accessing it,
+     or a SIGBUS signal may be raised. This happens, for instance, if the
+     file is shrinked. *)
+
+  val release: ('a, 'b, 'c) t -> unit
+  (** Release the resources associated with the given big array,
+     then set all of its dimensions to 0, causing subsequent accesses
+     to the big array to fail.  This releasing of resources is performed
+     automatically by the garbage collector when the big array is no longer
+     referenced by the program.  However, memory behavior of the program
+     can be improved by releasing the resources explicitly via
+     [Genarray.release] as soon as the big array is no longer useful.
+
+     If the big array was created with [Genarray.create], the memory
+     space occupied by its data is freed.  If the big array was
+     created with [Genarray.map_file], updates performed on the array
+     are flushed to the file (if the mapping is shared), then the
+     mapping is removed, freeing the corresponding virtual memory
+     space.  If several views on the big array data were created
+     using [Genarray.sub_*] or [Genarray.slice_*], data release occurs
+     when the last not-yet-released view is released.  Multiple calls
+     to [Genarray.release] on the same big array are safe: the second
+     and subsequent calls have no effect. *)
 
-  end
+end
 
 (** {6 One-dimensional arrays} *)
 
@@ -434,7 +460,7 @@ module Genarray :
 module Array1 : sig
   type ('a, 'b, 'c) t
   (** The type of one-dimensional big arrays whose elements have
-     Caml type ['a], representation kind ['b], and memory layout ['c]. *)
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
 
   val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t
   (** [Array1.create kind layout dim] returns a new bigarray of
@@ -490,16 +516,20 @@ module Array1 : sig
   (** Memory mapping of a file as a one-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
+  val release: ('a, 'b, 'c) t -> unit
+  (** Explicit release of the resources associated with the big array.
+     See {!Bigarray.Genarray.release} for more details. *)
+
   external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1"
   (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed.
       Use with caution and only when the program logic guarantees that
-      the access is within bounds. *)
+      the access is within bounds and the big array has not been released. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_1"
   (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed.
       Use with caution and only when the program logic guarantees that
-      the access is within bounds. *)
+      the access is within bounds and the big array has not been released. *)
 
 end
 
@@ -513,7 +543,7 @@ module Array2 :
   sig
   type ('a, 'b, 'c) t
   (** The type of two-dimensional big arrays whose elements have
-     Caml type ['a], representation kind ['b], and memory layout ['c]. *)
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
 
   val create: ('a, 'b) kind ->  'c layout -> int -> int -> ('a, 'b, 'c) t
   (** [Array2.create kind layout dim1 dim2] returns a new bigarray of
@@ -595,15 +625,21 @@ module Array2 :
   (** Memory mapping of a file as a two-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
+  val release: ('a, 'b, 'c) t -> unit
+  (** Explicit release of the resources associated with the big array.
+     See {!Bigarray.Genarray.release} for more details. *)
+
   external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a
                      = "%caml_ba_unsafe_ref_2"
-  (** Like {!Bigarray.Array2.get}, but bounds checking is not always
-      performed. *)
+  (** Like {!Bigarray.Array2.get}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds and the big array has not been released. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_2"
-  (** Like {!Bigarray.Array2.set}, but bounds checking is not always
-      performed. *)
+  (** Like {!Bigarray.Array2.set}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds and the big array has not been released. *)
 
 end
 
@@ -616,7 +652,7 @@ module Array3 :
   sig
   type ('a, 'b, 'c) t
   (** The type of three-dimensional big arrays whose elements have
-     Caml type ['a], representation kind ['b], and memory layout ['c]. *)
+     OCaml type ['a], representation kind ['b], and memory layout ['c]. *)
 
   val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t
   (** [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of
@@ -723,15 +759,21 @@ module Array3 :
   (** Memory mapping of a file as a three-dimensional big array.
      See {!Bigarray.Genarray.map_file} for more details. *)
 
+  val release: ('a, 'b, 'c) t -> unit
+  (** Explicit release of the resources associated with the big array.
+     See {!Bigarray.Genarray.release} for more details. *)
+
   external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a
                      = "%caml_ba_unsafe_ref_3"
-  (** Like {!Bigarray.Array3.get}, but bounds checking is not always
-      performed. *)
+  (** Like {!Bigarray.Array3.get}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds and the big array has not been released. *)
 
   external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit
                      = "%caml_ba_unsafe_set_3"
-  (** Like {!Bigarray.Array3.set}, but bounds checking is not always
-      performed. *)
+  (** Like {!Bigarray.Array3.set}, but bounds checking is not always performed.
+      Use with caution and only when the program logic guarantees that
+      the access is within bounds and the big array has not been released. *)
 
 end
 

diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c
index f4033dec979972d4b0c088c9de32f6b63e0ab1b6..4021b74aeed5c003067ccac0b81bd3e16ad2d6b0 100644 (file)
--- a/otherlibs/bigarray/bigarray_stubs.c
+++ b/otherlibs/bigarray/bigarray_stubs.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -21,6 +21,7 @@
 #include "custom.h"
 #include "fail.h"
 #include "intext.h"
+#include "hash.h"
 #include "memory.h"
 #include "mlvalues.h"
 
@@ -75,7 +76,8 @@ static struct custom_operations caml_ba_ops = {
   caml_ba_compare,
   caml_ba_hash,
   caml_ba_serialize,
-  caml_ba_deserialize
+  caml_ba_deserialize,
+  custom_compare_ext_default
 };
 
 /* Multiplication of unsigned longs with overflow detection */
@@ -121,20 +123,20 @@ caml_ba_multov(uintnat a, uintnat b, int * overflow)
 
 /* Allocation of a big array */
 
-#define CAML_BA_MAX_MEMORY 256*1024*1024
-/* 256 Mb -- after allocating that much, it's probably worth speeding
+#define CAML_BA_MAX_MEMORY 1024*1024*1024
+/* 1 Gb -- after allocating that much, it's probably worth speeding
    up the major GC */
 
 /* [caml_ba_alloc] will allocate a new bigarray object in the heap.
    If [data] is NULL, the memory for the contents is also allocated
    (with [malloc]) by [caml_ba_alloc].
-   [data] cannot point into the Caml heap.
-   [dim] may point into an object in the Caml heap.
+   [data] cannot point into the OCaml heap.
+   [dim] may point into an object in the OCaml heap.
 */
 CAMLexport value
 caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
 {
-  uintnat num_elts, size;
+  uintnat num_elts, asize, size;
   int overflow, i;
   value res;
   struct caml_ba_array * b;
@@ -158,10 +160,13 @@ caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
     if (data == NULL && size != 0) caml_raise_out_of_memory();
     flags |= CAML_BA_MANAGED;
   }
-  res = caml_alloc_custom(&caml_ba_ops,
-                          sizeof(struct caml_ba_array)
-                          + (num_dims - 1) * sizeof(intnat),
-                          size, CAML_BA_MAX_MEMORY);
+  /* PR#5516: use C99's flexible array types if possible */
+#if (__STDC_VERSION__ >= 199901L)
+  asize = sizeof(struct caml_ba_array) + num_dims * sizeof(intnat);
+#else
+  asize = sizeof(struct caml_ba_array) + (num_dims - 1) * sizeof(intnat);
+#endif
+  res = caml_alloc_custom(&caml_ba_ops, asize, size, CAML_BA_MAX_MEMORY);
   b = Caml_ba_array_val(res);
   b->data = data;
   b->num_dims = num_dims;
@@ -181,6 +186,7 @@ CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...)
   int i;
   value res;
 
+  Assert(num_dims <= CAML_BA_MAX_NUM_DIMS);
   va_start(ap, data);
   for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat);
   va_end(ap);
@@ -188,7 +194,7 @@ CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...)
   return res;
 }
 
-/* Allocate a bigarray from Caml */
+/* Allocate a bigarray from OCaml */
 
 CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim)
 {
@@ -490,18 +496,19 @@ CAMLprim value caml_ba_layout(value vb)
   return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK);
 }
 
-/* Finalization of a big array */
+/* Finalization / release of a big array */
 
 static void caml_ba_finalize(value v)
 {
   struct caml_ba_array * b = Caml_ba_array_val(v);
+  intnat i;
 
   switch (b->flags & CAML_BA_MANAGED_MASK) {
   case CAML_BA_EXTERNAL:
     break;
   case CAML_BA_MANAGED:
     if (b->proxy == NULL) {
-      free(b->data);
+      free(b->data);            /* no op if b->data = NULL */
     } else {
       if (-- b->proxy->refcount == 0) {
         free(b->proxy->data);
@@ -520,6 +527,17 @@ static void caml_ba_finalize(value v)
     }
     break;
   }
+  /* Make sure that subsequent accesses to the bigarray fail (empty bounds)
+     and that subsequent calls to caml_ba_finalize do nothing. */
+  for (i = 0; i < b->num_dims; i++) b->dim[i] = 0;
+  b->data = NULL;
+  b->proxy = NULL;
+}
+
+CAMLprim value caml_ba_release(value v)
+{
+  caml_ba_finalize(v);
+  return Val_unit;
 }
 
 /* Comparison of two big arrays */
@@ -621,69 +639,85 @@ static int caml_ba_compare(value v1, value v2)
 static intnat caml_ba_hash(value v)
 {
   struct caml_ba_array * b = Caml_ba_array_val(v);
-  intnat num_elts, n, h;
+  intnat num_elts, n;
+  uint32 h, w;
   int i;
 
   num_elts = 1;
   for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
-  if (num_elts >= 50) num_elts = 50;
   h = 0;
 
-#define COMBINE(h,v) ((h << 4) + h + (v))
-
   switch (b->flags & CAML_BA_KIND_MASK) {
   case CAML_BA_SINT8:
   case CAML_BA_UINT8: {
     uint8 * p = b->data;
-    for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
+    if (num_elts > 256) num_elts = 256;
+    for (n = 0; n + 4 <= num_elts; n += 4, p += 4) {
+      w = p[0] | (p[1] << 8) | (p[2] << 16) | (p[3] << 24);
+      h = caml_hash_mix_uint32(h, w);
+    }
+    w = 0;
+    switch (num_elts & 3) {
+    case 3: w  = p[2] << 16;    /* fallthrough */
+    case 2: w |= p[1] << 8;     /* fallthrough */
+    case 1: w |= p[0];
+            h = caml_hash_mix_uint32(h, w);
+    }
     break;
   }
   case CAML_BA_SINT16:
   case CAML_BA_UINT16: {
     uint16 * p = b->data;
-    for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
+    if (num_elts > 128) num_elts = 128;
+    for (n = 0; n + 2 <= num_elts; n += 2, p += 2) {
+      w = p[0] | (p[1] << 16);
+      h = caml_hash_mix_uint32(h, w);
+    }
+    if ((num_elts & 1) != 0)
+      h = caml_hash_mix_uint32(h, p[0]);
     break;
   }
-  case CAML_BA_FLOAT32:
-  case CAML_BA_COMPLEX32:
   case CAML_BA_INT32:
-#ifndef ARCH_SIXTYFOUR
-  case CAML_BA_CAML_INT:
-  case CAML_BA_NATIVE_INT:
-#endif
   {
     uint32 * p = b->data;
-    for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_uint32(h, *p);
     break;
   }
-  case CAML_BA_FLOAT64:
-  case CAML_BA_COMPLEX64:
-  case CAML_BA_INT64:
-#ifdef ARCH_SIXTYFOUR
   case CAML_BA_CAML_INT:
   case CAML_BA_NATIVE_INT:
-#endif
-#ifdef ARCH_SIXTYFOUR
   {
-    uintnat * p = b->data;
-    for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
+    intnat * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_intnat(h, *p);
     break;
   }
-#else
+  case CAML_BA_INT64:
   {
-    uint32 * p = b->data;
-    for (n = 0; n < num_elts; n++) {
-#ifdef ARCH_BIG_ENDIAN
-      h = COMBINE(h, p[1]); h = COMBINE(h, p[0]); p += 2;
-#else
-      h = COMBINE(h, p[0]); h = COMBINE(h, p[1]); p += 2;
-#endif
-    }
+    int64 * p = b->data;
+    if (num_elts > 32) num_elts = 32;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_int64(h, *p);
+    break;
+  }
+  case CAML_BA_COMPLEX32:
+    num_elts *= 2;              /* fallthrough */
+  case CAML_BA_FLOAT32:
+  {
+    float * p = b->data;
+    if (num_elts > 64) num_elts = 64;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_float(h, *p);
+    break;
+  }
+  case CAML_BA_COMPLEX64:
+    num_elts *= 2;              /* fallthrough */
+  case CAML_BA_FLOAT64:
+  {
+    double * p = b->data;
+    if (num_elts > 32) num_elts = 32;
+    for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_double(h, *p);
     break;
   }
-#endif
   }
-#undef COMBINE
   return h;
 }
 
@@ -755,7 +789,7 @@ static void caml_ba_serialize(value v,
     caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF);
     break;
   }
-  /* Compute required size in Caml heap.  Assumes struct caml_ba_array
+  /* Compute required size in OCaml heap.  Assumes struct caml_ba_array
      is exactly 4 + num_dims words */
   Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value));
   *wsize_32 = (4 + b->num_dims) * 4;
@@ -776,7 +810,7 @@ static void caml_ba_deserialize_longarray(void * dest, intnat num_elts)
 #else
   if (sixty)
     caml_deserialize_error("input_value: cannot read bigarray "
-                      "with 64-bit Caml ints");
+                      "with 64-bit OCaml ints");
   caml_deserialize_block_4(dest, num_elts);
 #endif
 }
@@ -887,7 +921,7 @@ CAMLprim value caml_ba_slice(value vb, value vind)
   sub_data =
     (char *) b->data +
     offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
-  /* Allocate a Caml bigarray to hold the result */
+  /* Allocate an OCaml bigarray to hold the result */
   res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
   /* Create or update proxy in case of managed bigarray */
   caml_ba_update_proxy(b, Caml_ba_array_val(res));
@@ -928,7 +962,7 @@ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen)
   sub_data =
     (char *) b->data +
     ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
-  /* Allocate a Caml bigarray to hold the result */
+  /* Allocate an OCaml bigarray to hold the result */
   res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim);
   /* Doctor the changed dimension */
   Caml_ba_array_val(res)->dim[changed_dim] = len;
@@ -1062,7 +1096,7 @@ CAMLprim value caml_ba_reshape(value vb, value vdim)
   num_elts = 1;
   for (i = 0; i < num_dims; i++) {
     dim[i] = Long_val(Field(vdim, i));
-    if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL)
+    if (dim[i] < 0)
       caml_invalid_argument("Bigarray.reshape: negative dimension");
     num_elts *= dim[i];
   }

diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c
index 6af03930206e836509f712882029be1179c8f2fe..30294cc4bbe07d5e54a82b2329924e80808371b3 100644 (file)
--- a/otherlibs/bigarray/mmap_unix.c
+++ b/otherlibs/bigarray/mmap_unix.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -25,12 +25,14 @@
 
 extern int caml_ba_element_size[];  /* from bigarray_stubs.c */
 
+#include <errno.h>
 #ifdef HAS_UNISTD
 #include <unistd.h>
 #endif
 #ifdef HAS_MMAP
 #include <sys/types.h>
 #include <sys/mman.h>
+#include <sys/stat.h>
 #endif
 
 #if defined(HAS_MMAP)
@@ -39,15 +41,61 @@ extern int caml_ba_element_size[];  /* from bigarray_stubs.c */
 #define MAP_FAILED ((void *) -1)
 #endif
 
+/* [caml_grow_file] function contributed by Gerd Stolpmann (PR#5543). */
+
+static int caml_grow_file(int fd, file_offset size)
+{
+  char c;
+  int p;
+
+  /* First use pwrite for growing - it is a conservative method, as it
+     can never happen that we shrink by accident
+   */
+#ifdef HAS_PWRITE
+  c = 0;
+  p = pwrite(fd, &c, 1, size - 1);
+#else
+
+  /* Emulate pwrite with lseek. This should only be necessary on ancient
+     systems nowadays
+   */
+  file_offset currpos;
+  currpos = lseek(fd, 0, SEEK_CUR);
+  if (currpos != -1) {
+    p = lseek(fd, size - 1, SEEK_SET);
+    if (p != -1) {
+      c = 0;
+      p = write(fd, &c, 1);
+      if (p != -1) 
+        p = lseek(fd, currpos, SEEK_SET);
+    }
+  }
+  else p=-1;
+#endif
+#ifdef HAS_TRUNCATE
+  if (p == -1 && errno == ESPIPE) {
+    /* Plan B. Check if at least ftruncate is possible. There are
+       some non-seekable descriptor types that do not support pwrite
+       but ftruncate, like shared memory. We never get into this case
+       for real files, so there is no danger of truncating persistent
+       data by accident
+     */
+    p = ftruncate(fd, size);
+  }
+#endif
+  return p;
+}
+
+
 CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
                                 value vshared, value vdim, value vstart)
 {
   int fd, flags, major_dim, shared;
   intnat num_dims, i;
   intnat dim[CAML_BA_MAX_NUM_DIMS];
-  file_offset currpos, startpos, file_size, data_size;
+  file_offset startpos, file_size, data_size;
+  struct stat st;
   uintnat array_size, page, delta;
-  char c;
   void * addr;
 
   fd = Int_val(vfd);
@@ -55,7 +103,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
   startpos = File_offset_val(vstart);
   num_dims = Wosize_val(vdim);
   major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
-  /* Extract dimensions from Caml array */
+  /* Extract dimensions from OCaml array */
   num_dims = Wosize_val(vdim);
   if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
     caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
@@ -65,18 +113,15 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
     if (dim[i] < 0)
       caml_invalid_argument("Bigarray.create: negative dimension");
   }
-  /* Determine file size */
+  /* Determine file size. We avoid lseek here because it is fragile,
+     and because some mappable file types do not support it
+   */
   caml_enter_blocking_section();
-  currpos = lseek(fd, 0, SEEK_CUR);
-  if (currpos == -1) {
-    caml_leave_blocking_section();
-    caml_sys_error(NO_ARG);
-  }
-  file_size = lseek(fd, 0, SEEK_END);
-  if (file_size == -1) {
+  if (fstat(fd, &st) == -1) {
     caml_leave_blocking_section();
     caml_sys_error(NO_ARG);
   }
+  file_size = st.st_size;
   /* Determine array size in bytes (or size of array without the major
      dimension if that dimension wasn't specified) */
   array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK];
@@ -99,37 +144,33 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
   } else {
     /* Check that file is large enough, and grow it otherwise */
     if (file_size < startpos + array_size) {
-      if (lseek(fd, startpos + array_size - 1, SEEK_SET) == -1) {
-        caml_leave_blocking_section();
-        caml_sys_error(NO_ARG);
-      }
-      c = 0;
-      if (write(fd, &c, 1) != 1) {
+      if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */
         caml_leave_blocking_section();
         caml_sys_error(NO_ARG);
       }
     }
   }
-  /* Restore original file position */
-  lseek(fd, currpos, SEEK_SET);
   /* Determine offset so that the mapping starts at the given file pos */
   page = getpagesize();
-  delta = (uintnat) (startpos % page);
+  delta = (uintnat) startpos % page;
   /* Do the mmap */
   shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE;
-  addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
-              shared, fd, startpos - delta);
+  if (array_size > 0)
+    addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE,
+                shared, fd, startpos - delta);
+  else
+    addr = NULL;                /* PR#5463 - mmap fails on empty region */
   caml_leave_blocking_section();
   if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG);
   addr = (void *) ((uintnat) addr + delta);
-  /* Build and return the Caml bigarray */
+  /* Build and return the OCaml bigarray */
   return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
 }
 
 #else
 
-value caml_ba_map_file(value vfd, value vkind, value vlayout,
-                       value vshared, value vdim, value vpos)
+CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
+                                value vshared, value vdim, value vpos)
 {
   caml_invalid_argument("Bigarray.map_file: not supported");
   return Val_unit;
@@ -148,6 +189,12 @@ void caml_ba_unmap_file(void * addr, uintnat len)
 #if defined(HAS_MMAP)
   uintnat page = getpagesize();
   uintnat delta = (uintnat) addr % page;
-  munmap((void *)((uintnat)addr - delta), len + delta);
+  if (len == 0) return;         /* PR#5463 */
+  addr = (void *)((uintnat)addr - delta);
+  len  = len + delta;
+#if defined(_POSIX_SYNCHRONIZED_IO)
+  msync(addr, len, MS_ASYNC);   /* PR#3571 */
+#endif
+  munmap(addr, len);
 #endif
 }

diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c
index 9be9e18e0187fb24bb8d3275373e6c2bd5b78bc2..ded2270ee66c1065c34e0f36636a937288a7622a 100644 (file)
--- a/otherlibs/bigarray/mmap_win32.c
+++ b/otherlibs/bigarray/mmap_win32.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
 /*                                                                     */
@@ -62,7 +62,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
   startpos = Int64_val(vstart);
   num_dims = Wosize_val(vdim);
   major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0;
-  /* Extract dimensions from Caml array */
+  /* Extract dimensions from OCaml array */
   num_dims = Wosize_val(vdim);
   if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
     caml_invalid_argument("Bigarray.mmap: bad number of dimensions");
@@ -117,7 +117,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout,
   addr = (void *) ((uintnat) addr + delta);
   /* Close the file mapping */
   CloseHandle(fmap);
-  /* Build and return the Caml bigarray */
+  /* Build and return the OCaml bigarray */
   return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim);
 }
 

diff --git a/otherlibs/dbm/.cvsignore b/otherlibs/dbm/.cvsignore
deleted file mode 100644 (file)
index 29fea47..0000000
--- a/otherlibs/dbm/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-so_locations
-*.so
-*.a

diff --git a/otherlibs/dbm/.depend b/otherlibs/dbm/.depend
deleted file mode 100644 (file)
index 4e5750f..0000000
--- a/otherlibs/dbm/.depend
+++ /dev/null
@@ -1,3 +0,0 @@
-dbm.cmi:
-dbm.cmo: dbm.cmi
-dbm.cmx: dbm.cmi

diff --git a/otherlibs/dbm/Makefile b/otherlibs/dbm/Makefile
deleted file mode 100644 (file)
index 099327d..0000000
--- a/otherlibs/dbm/Makefile
+++ /dev/null
@@ -1,32 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
-#                                                                       #
-#   Copyright 1999 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the GNU Library General Public License, with     #
-#   the special exception on linking described in file ../../LICENSE.   #
-#                                                                       #
-#########################################################################
-
-# $Id$
-
-# Makefile for the ndbm library
-
-LIBNAME=dbm
-CLIBNAME=mldbm
-CAMLOBJS=dbm.cmo
-COBJS=cldbm.o
-EXTRACFLAGS=$(DBM_INCLUDES)
-LINKOPTS=$(DBM_LINK)
-LDOPTS=-ldopt "$(DBM_LINK)"
-
-include ../Makefile
-
-
-depend:
-       ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml > .depend
-
-include .depend

diff --git a/otherlibs/dbm/cldbm.c b/otherlibs/dbm/cldbm.c
deleted file mode 100644 (file)
index 0d6cb36..0000000
--- a/otherlibs/dbm/cldbm.c
+++ /dev/null
@@ -1,166 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Francois Rouaix, projet Cristal, INRIA Rocquencourt      */
-/*                                                                     */
-/*  Copyright 1996 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../../LICENSE.  */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <string.h>
-#include <fcntl.h>
-#include <mlvalues.h>
-#include <alloc.h>
-#include <memory.h>
-#include <fail.h>
-#include <callback.h>
-
-#ifdef DBM_USES_GDBM_NDBM
-#include <gdbm-ndbm.h>
-#else
-#include <ndbm.h>
-#endif
-
-/* Quite close to sys_open_flags, but we need RDWR */
-static int dbm_open_flags[] = {
-  O_RDONLY, O_WRONLY, O_RDWR, O_CREAT
-};
-
-static void raise_dbm (char *errmsg) Noreturn;
-
-static void raise_dbm(char *errmsg)
-{
-  static value * dbm_exn = NULL;
-  if (dbm_exn == NULL)
-    dbm_exn = caml_named_value("dbmerror");
-  raise_with_string(*dbm_exn, errmsg);
-}
-
-#define DBM_val(v) *((DBM **) &Field(v, 0))
-
-static value alloc_dbm(DBM * db)
-{
-  value res = alloc_small(1, Abstract_tag);
-  DBM_val(res) = db;
-  return res;
-}
-
-static DBM * extract_dbm(value vdb)
-{
-  if (DBM_val(vdb) == NULL) raise_dbm("DBM has been closed");
-  return DBM_val(vdb);
-}
-
-/* Dbm.open : string -> Sys.open_flag list -> int -> t */
-value caml_dbm_open(value vfile, value vflags, value vmode) /* ML */
-{
-  char *file = String_val(vfile);
-  int flags = convert_flag_list(vflags, dbm_open_flags);
-  int mode = Int_val(vmode);
-  DBM *db = dbm_open(file,flags,mode);
-
-  if (db == NULL)
-    raise_dbm("Can't open file");
-  else
-    return (alloc_dbm(db));
-}
-
-/* Dbm.close: t -> unit */
-value caml_dbm_close(value vdb)       /* ML */
-{
-  dbm_close(extract_dbm(vdb));
-  DBM_val(vdb) = NULL;
-  return Val_unit;
-}
-
-/* Dbm.fetch: t -> string -> string */
-value caml_dbm_fetch(value vdb, value vkey)  /* ML */
-{
-  datum key,answer;
-  key.dptr = String_val(vkey);
-  key.dsize = string_length(vkey);
-  answer = dbm_fetch(extract_dbm(vdb), key);
-  if (answer.dptr) {
-    value res = alloc_string(answer.dsize);
-    memmove (String_val (res), answer.dptr, answer.dsize);
-    return res;
-  }
-  else raise_not_found();
-}
-
-value caml_dbm_insert(value vdb, value vkey, value vcontent) /* ML */
-{
-  datum key, content;
-
-  key.dptr = String_val(vkey);
-  key.dsize = string_length(vkey);
-  content.dptr = String_val(vcontent);
-  content.dsize = string_length(vcontent);
-
-  switch(dbm_store(extract_dbm(vdb), key, content, DBM_INSERT)) {
-  case 0:
-    return Val_unit;
-  case 1:                       /* DBM_INSERT and already existing */
-    raise_dbm("Entry already exists");
-  default:
-    raise_dbm("dbm_store failed");
-  }
-}
-
-value caml_dbm_replace(value vdb, value vkey, value vcontent) /* ML */
-{
-  datum key, content;
-
-  key.dptr = String_val(vkey);
-  key.dsize = string_length(vkey);
-  content.dptr = String_val(vcontent);
-  content.dsize = string_length(vcontent);
-
-  switch(dbm_store(extract_dbm(vdb), key, content, DBM_REPLACE)) {
-  case 0:
-    return Val_unit;
-  default:
-    raise_dbm("dbm_store failed");
-  }
-}
-
-value caml_dbm_delete(value vdb, value vkey)         /* ML */
-{
-  datum key;
-  key.dptr = String_val(vkey);
-  key.dsize = string_length(vkey);
-
-  if (dbm_delete(extract_dbm(vdb), key) < 0)
-    raise_dbm("dbm_delete");
-  else return Val_unit;
-}
-
-value caml_dbm_firstkey(value vdb)            /* ML */
-{
-  datum key = dbm_firstkey(extract_dbm(vdb));
-
-  if (key.dptr) {
-    value res = alloc_string(key.dsize);
-    memmove (String_val (res), key.dptr, key.dsize);
-    return res;
-  }
-  else raise_not_found();
-}
-
-value caml_dbm_nextkey(value vdb)             /* ML */
-{
-  datum key = dbm_nextkey(extract_dbm(vdb));
-
-  if (key.dptr) {
-    value res = alloc_string(key.dsize);
-    memmove (String_val (res), key.dptr, key.dsize);
-    return res;
-  }
-  else raise_not_found();
-}

diff --git a/otherlibs/dbm/dbm.ml b/otherlibs/dbm/dbm.ml
deleted file mode 100644 (file)
index f31d299..0000000
--- a/otherlibs/dbm/dbm.ml
+++ /dev/null
@@ -1,58 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*          Francois Rouaix, projet Cristal, INRIA Rocquencourt        *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the GNU Library General Public License, with    *)
-(*  the special exception on linking described in file ../../LICENSE.  *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type t
-
-type open_flag =
-   Dbm_rdonly | Dbm_wronly | Dbm_rdwr | Dbm_create
-
-type dbm_flag =
-   DBM_INSERT
- | DBM_REPLACE
-
-exception Dbm_error of string
-
-external raw_opendbm : string -> open_flag list -> int -> t
-              = "caml_dbm_open"
-
-let opendbm file flags mode =
-  try
-    raw_opendbm file flags mode
-  with Dbm_error msg ->
-    raise(Dbm_error("Can't open file " ^ file))
-
- (* By exporting opendbm as val, we are sure to link in this
-    file (we must register the exception). Since t is abstract, programs
-    have to call it in order to do anything *)
-
-external close : t -> unit = "caml_dbm_close"
-external find : t -> string -> string = "caml_dbm_fetch"
-external add : t -> string -> string -> unit = "caml_dbm_insert"
-external replace : t -> string -> string -> unit = "caml_dbm_replace"
-external remove : t -> string -> unit = "caml_dbm_delete"
-external firstkey : t -> string = "caml_dbm_firstkey"
-external nextkey : t -> string = "caml_dbm_nextkey"
-
-let _ = Callback.register_exception "dbmerror" (Dbm_error "")
-
-(* Usual iterator *)
-let iter f t =
-  let rec walk = function
-      None -> ()
-    | Some k ->
-        f k (find t k);
-        walk (try Some(nextkey t) with Not_found -> None)
-  in
-  walk (try Some(firstkey t) with Not_found -> None)

diff --git a/otherlibs/dbm/dbm.mli b/otherlibs/dbm/dbm.mli
deleted file mode 100644 (file)
index f992442..0000000
--- a/otherlibs/dbm/dbm.mli
+++ /dev/null
@@ -1,79 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*          Francois Rouaix, projet Cristal, INRIA Rocquencourt        *)
-(*                                                                     *)
-(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the GNU Library General Public License, with    *)
-(*  the special exception on linking described in file ../../LICENSE.  *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Interface to the NDBM database. *)
-
-type t
-(** The type of file descriptors opened on NDBM databases. *)
-
-
-type open_flag =
-    Dbm_rdonly
-  | Dbm_wronly
-  | Dbm_rdwr
-  | Dbm_create
-(** Flags for opening a database (see {!Dbm.opendbm}). *)
-
-
-exception Dbm_error of string
-(** Raised by the following functions when an error is encountered. *)
-
-val opendbm : string -> open_flag list -> int -> t
-(** Open a descriptor on an NDBM database. The first argument is
-   the name of the database (without the [.dir] and [.pag] suffixes).
-   The second argument is a list of flags: [Dbm_rdonly] opens
-   the database for reading only, [Dbm_wronly] for writing only,
-   [Dbm_rdwr] for reading and writing; [Dbm_create] causes the
-   database to be created if it does not already exist.
-   The third argument is the permissions to give to the database
-   files, if the database is created. *)
-
-external close : t -> unit = "caml_dbm_close"
-(** Close the given descriptor. *)
-
-external find : t -> string -> string = "caml_dbm_fetch"
-(** [find db key] returns the data associated with the given
-   [key] in the database opened for the descriptor [db].
-   Raise [Not_found] if the [key] has no associated data. *)
-
-external add : t -> string -> string -> unit = "caml_dbm_insert"
-(** [add db key data] inserts the pair ([key], [data]) in
-   the database [db]. If the database already contains data
-   associated with [key], raise [Dbm_error "Entry already exists"]. *)
-
-external replace : t -> string -> string -> unit = "caml_dbm_replace"
-(** [replace db key data] inserts the pair ([key], [data]) in
-   the database [db]. If the database already contains data
-   associated with [key], that data is discarded and silently
-   replaced by the new [data]. *)
-
-external remove : t -> string -> unit = "caml_dbm_delete"
-(** [remove db key data] removes the data associated with [key]
-   in [db]. If [key] has no associated data, raise
-   [Dbm_error "dbm_delete"]. *)
-
-external firstkey : t -> string = "caml_dbm_firstkey"
-(** See {!Dbm.nextkey}.*)
-
-external nextkey : t -> string = "caml_dbm_nextkey"
-(** Enumerate all keys in the given database, in an unspecified order.
-   [firstkey db] returns the first key, and repeated calls
-   to [nextkey db] return the remaining keys. [Not_found] is raised
-   when all keys have been enumerated. *)
-
-val iter : (string -> string -> 'a) -> t -> unit
-(** [iter f db] applies [f] to each ([key], [data]) pair in
-   the database [db]. [f] receives [key] as first argument
-   and [data] as second argument. *)

diff --git a/otherlibs/dbm/libmldbm.clib b/otherlibs/dbm/libmldbm.clib
deleted file mode 100644 (file)
index 3a63b87..0000000
--- a/otherlibs/dbm/libmldbm.clib
+++ /dev/null
@@ -1 +0,0 @@
-cldbm.o

diff --git a/otherlibs/dynlink/.cvsignore b/otherlibs/dynlink/.cvsignore
deleted file mode 100644 (file)
index 29b3102..0000000
--- a/otherlibs/dynlink/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-extract_crc
-*.a

diff --git a/otherlibs/dynlink/.ignore b/otherlibs/dynlink/.ignore
new file mode 100644 (file)
index 0000000..5ea9775
--- /dev/null
+++ b/otherlibs/dynlink/.ignore
@@ -0,0 +1 @@
+extract_crc

diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile
index 3da485f47565c379068b2650663b0c5f677ec2d4..e6a632956b103a8393890b2aa5438573e48da2d2 100644 (file)
--- a/otherlibs/dynlink/Makefile
+++ b/otherlibs/dynlink/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -28,7 +28,7 @@ COMPILEROBJS=\
   ../../utils/misc.cmo ../../utils/config.cmo ../../utils/clflags.cmo \
   ../../utils/tbl.cmo ../../utils/consistbl.cmo \
   ../../utils/terminfo.cmo ../../utils/warnings.cmo \
-  ../../parsing/asttypes.cmi ../../parsing/linenum.cmo \
+  ../../parsing/asttypes.cmi \
   ../../parsing/location.cmo ../../parsing/longident.cmo \
   ../../typing/ident.cmo ../../typing/path.cmo \
   ../../typing/primitive.cmo ../../typing/types.cmo \

diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt
index 3d8b84b77a26492a705cb753742e61c0c0a9cd40..31ee136d618a2992748827c51f8612f5ba378988 100644 (file)
--- a/otherlibs/dynlink/Makefile.nt
+++ b/otherlibs/dynlink/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml
index 0d324a8540d8a2180a2b0a0112e5b42be0a233b1..7415ae6c2d961eaf2ef92f9d4c649e6c2ca1f018 100644 (file)
--- a/otherlibs/dynlink/dynlink.ml
+++ b/otherlibs/dynlink/dynlink.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -121,8 +121,7 @@ let digest_interface unit loadpath =
       raise (Error(File_not_found shortname)) in
   let ic = open_in_bin filename in
   try
-    let buffer = String.create (String.length Config.cmi_magic_number) in
-    really_input ic buffer 0 (String.length Config.cmi_magic_number);
+    let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in
     if buffer <> Config.cmi_magic_number then begin
       close_in ic;
       raise(Error(Corrupted_interface filename))
@@ -159,7 +158,10 @@ let check_unsafe_module cu =
 
 (* Load in-core and execute a bytecode object file *)
 
-let load_compunit ic file_name compunit =
+external register_code_fragment: string -> int -> string -> unit
+                               = "caml_register_code_fragment"
+
+let load_compunit ic file_name file_digest compunit =
   check_consistency file_name compunit;
   check_unsafe_module compunit;
   seek_in ic compunit.cu_pos;
@@ -188,6 +190,11 @@ let load_compunit ic file_name compunit =
       | _ -> assert false in
     raise(Error(Linking_error (file_name, new_error)))
   end;
+  (* PR#5215: identify this code fragment by 
+     digest of file contents + unit name.
+     Unit name is needed for .cma files, which produce several code fragments.*)
+  let digest = Digest.string (file_digest ^ compunit.cu_name) in
+  register_code_fragment code code_size digest;
   begin try
     ignore((Meta.reify_bytecode code code_size) ())
   with exn ->
@@ -199,16 +206,18 @@ let loadfile file_name =
   init();
   if not (Sys.file_exists file_name) then raise(Error (File_not_found file_name));
   let ic = open_in_bin file_name in
+  let file_digest = Digest.channel ic (-1) in
+  seek_in ic 0;
   try
-    let buffer = String.create (String.length Config.cmo_magic_number) in
-    begin
-      try really_input ic buffer 0 (String.length Config.cmo_magic_number)
-      with End_of_file -> raise(Error(Not_a_bytecode_file file_name))
-    end;
+    let buffer =
+      try Misc.input_bytes ic (String.length Config.cmo_magic_number)
+      with End_of_file -> raise (Error (Not_a_bytecode_file file_name))
+    in
     if buffer = Config.cmo_magic_number then begin
       let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
       seek_in ic compunit_pos;
-      load_compunit ic file_name (input_value ic : compilation_unit)
+      let cu = (input_value ic : compilation_unit) in
+      load_compunit ic file_name file_digest cu
     end else
     if buffer = Config.cma_magic_number then begin
       let toc_pos = input_binary_int ic in  (* Go to table of contents *)
@@ -220,7 +229,7 @@ let loadfile file_name =
       with Failure reason ->
         raise(Error(Cannot_open_dll reason))
       end;
-      List.iter (load_compunit ic file_name) lib.lib_units
+      List.iter (load_compunit ic file_name file_digest) lib.lib_units
     end else
       raise(Error(Not_a_bytecode_file file_name));
     close_in ic

diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli
index 7cca68c5a09020fa892dffec9d61647cf516fd5a..849f1e148e2f93e968317cdd49ab215802646cd4 100644 (file)
--- a/otherlibs/dynlink/dynlink.mli
+++ b/otherlibs/dynlink/dynlink.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -98,7 +98,7 @@ val add_available_units : (string * Digest.t) list -> unit
     for each unit. This way, the [.cmi] interface files need not be
     available at run-time. The digests can be extracted from [.cmi]
     files using the [extract_crc] program installed in the
-    Objective Caml standard library directory. *)
+    OCaml standard library directory. *)
 
 val clear_available_units : unit -> unit
 (** Empty the list of compilation units accessible to dynamically-linked

diff --git a/otherlibs/dynlink/extract_crc.ml b/otherlibs/dynlink/extract_crc.ml
index e7d9139bed7ef7ca1fbdfcfd0ed0c6da902349ca..672ca6ea97130ff6d1a34c7a50453a14195fd412 100644 (file)
--- a/otherlibs/dynlink/extract_crc.ml
+++ b/otherlibs/dynlink/extract_crc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml
index 6ab9b9850ae41012b0cc6d3208f972a8078a6754..d980a7b901a637c78c1afb0d79d34107cf388882 100644 (file)
--- a/otherlibs/dynlink/natdynlink.ml
+++ b/otherlibs/dynlink/natdynlink.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/graph/.cvsignore b/otherlibs/graph/.cvsignore
deleted file mode 100644 (file)
index 29fea47..0000000
--- a/otherlibs/graph/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-so_locations
-*.so
-*.a

diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend
index 54df0691ffb2d08f0f3290a30453b935c502b505..f72f26bd7d1440d69c7a612c7700364f9870dcfd 100644 (file)
--- a/otherlibs/graph/.depend
+++ b/otherlibs/graph/.depend
@@ -1,106 +1,106 @@
-color.o: color.c libgraph.h \
-  \
-  \
-  \
+color.o: color.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h \
- 
-draw.o: draw.c libgraph.h \
-  \
-  \
-  \
+  /opt/local/include/X11/Xatom.h
+draw.o: draw.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/mlvalues.h
-dump_img.o: dump_img.c libgraph.h \
-  \
-  \
-  \
+dump_img.o: dump_img.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h image.h \
   ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/memory.h \
   ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h
-events.o: events.c libgraph.h \
-  \
-  \
-  \
+events.o: events.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/mlvalues.h ../../byterun/signals.h
-fill.o: fill.c libgraph.h \
-  \
-  \
-  \
+fill.o: fill.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/memory.h \
   ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h
-image.o: image.c libgraph.h \
-  \
-  \
-  \
+image.o: image.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h image.h \
   ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h
-make_img.o: make_img.c libgraph.h \
-  \
-  \
-  \
+make_img.o: make_img.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h image.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/mlvalues.h \
   ../../byterun/major_gc.h ../../byterun/freelist.h \
   ../../byterun/minor_gc.h
-open.o: open.c libgraph.h \
-  \
-  \
-  \
+open.o: open.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/mlvalues.h ../../byterun/callback.h ../../byterun/fail.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h
-point_col.o: point_col.c libgraph.h \
-  \
-  \
-  \
+point_col.o: point_col.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h
-sound.o: sound.c libgraph.h \
-  \
-  \
-  \
+sound.o: sound.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h
-subwindow.o: subwindow.c libgraph.h \
-  \
-  \
-  \
+subwindow.o: subwindow.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h
-text.o: text.c libgraph.h \
-  \
-  \
-  \
+text.o: text.c libgraph.h /opt/local/include/X11/Xlib.h \
+  /opt/local/include/X11/X.h /opt/local/include/X11/Xfuncproto.h \
+  /opt/local/include/X11/Xosdefs.h /opt/local/include/X11/Xutil.h \
+  /opt/local/include/X11/keysym.h /opt/local/include/X11/keysymdef.h \
   ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \
   ../../byterun/mlvalues.h
-graphics.cmi:
-graphicsX11.cmi:
-graphics.cmo: graphics.cmi
-graphics.cmx: graphics.cmi
-graphicsX11.cmo: graphics.cmi graphicsX11.cmi
-graphicsX11.cmx: graphics.cmx graphicsX11.cmi
+graphics.cmi :
+graphicsX11.cmi :
+graphics.cmo : graphics.cmi
+graphics.cmx : graphics.cmi
+graphicsX11.cmo : graphics.cmi graphicsX11.cmi
+graphicsX11.cmx : graphics.cmx graphicsX11.cmi

diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile
index 2be984465614dc1b955f0df7e5217af88f621ba0..19c4612ed7803c02b25c975cc2cb345f824f764f 100644 (file)
--- a/otherlibs/graph/Makefile
+++ b/otherlibs/graph/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c
index 0dc29670716acb3f86b33bf4b668a682e96db878..bdd8b5e2831eb54ea97135e54f799b26eaada7f1 100644 (file)
--- a/otherlibs/graph/color.c
+++ b/otherlibs/graph/color.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c
index 35a4ae175577af34306a7b6508c1682997fb9983..0419c627031c2cccced4bc734d281fce8e0b86a9 100644 (file)
--- a/otherlibs/graph/draw.c
+++ b/otherlibs/graph/draw.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c
index 8c82c21bfb4cb3d6bd81affee9d349ef6ad218eb..66185d8750ad1b34afedfa915b9a7c07622e9850 100644 (file)
--- a/otherlibs/graph/dump_img.c
+++ b/otherlibs/graph/dump_img.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c
index d9563a3970d675fd3a768cfe453e45f224c0b64b..508931055c8b2facd10254e150c9f9736bf0fd93 100644 (file)
--- a/otherlibs/graph/events.c
+++ b/otherlibs/graph/events.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c
index 0430c14a6310a84ebf14db3f732633dbf7c4e7d1..bb1a60e78b2df8b90e055e63de4d534fbf80c7c3 100644 (file)
--- a/otherlibs/graph/fill.c
+++ b/otherlibs/graph/fill.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml
index 96a2471612b47825c37c13820982b82bbaf4328f..a9dd511401c1e2eb11c2df1062aab10c2834b2c5 100644 (file)
--- a/otherlibs/graph/graphics.ml
+++ b/otherlibs/graph/graphics.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli
index 23d61a39aaa3a12956dce042a81f2fa016b811d8..10074cb7af4d51dcafc9134f2a2c2ecd646be71f 100644 (file)
--- a/otherlibs/graph/graphics.mli
+++ b/otherlibs/graph/graphics.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml
index 85f5a436051008df3d0f69c75d92c19dd881995b..4b70d29bd3da53f730ac278332ff7fb90cd28a55 100644 (file)
--- a/otherlibs/graph/graphicsX11.ml
+++ b/otherlibs/graph/graphicsX11.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)

diff --git a/otherlibs/graph/graphicsX11.mli b/otherlibs/graph/graphicsX11.mli
index 1118253711e495f0672c98884f89a810877d4bcc..0210d9676d948da82189d274e397d37d8f522757 100644 (file)
--- a/otherlibs/graph/graphicsX11.mli
+++ b/otherlibs/graph/graphicsX11.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Pierre Weis and Jun Furuse, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -18,12 +18,12 @@
 type window_id = string
 
 val window_id : unit -> window_id
-(** Return the unique identifier of the Caml graphics window.
+(** Return the unique identifier of the OCaml graphics window.
    The returned string is an unsigned 32 bits integer
    in decimal form. *)
 
 val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id
-(** Create a sub-window of the current Caml graphics window
+(** Create a sub-window of the current OCaml graphics window
    and return its identifier. *)
 
 val close_subwindow : window_id -> unit

diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c
index 501398b358eb0b27522f2f2129ba19bb37ed91b3..c610d96b6f3687113240d46f822555b629d5a214 100644 (file)
--- a/otherlibs/graph/image.c
+++ b/otherlibs/graph/image.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -30,7 +30,8 @@ static struct custom_operations image_ops = {
   custom_compare_default,
   custom_hash_default,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 #define Max_image_mem 2000000

diff --git a/otherlibs/graph/image.h b/otherlibs/graph/image.h
index 539cf9f8ca957262f9ec608d22f4e237bd7729fd..76d319e0abdd9a901114422b83a41571e5cc2546 100644 (file)
--- a/otherlibs/graph/image.h
+++ b/otherlibs/graph/image.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h
index d2df1c1ae08d16b3d4dda9c989de838318bc573a..c8192e05b0dbf1f093b65bdb65d80feb79663eff 100644 (file)
--- a/otherlibs/graph/libgraph.h
+++ b/otherlibs/graph/libgraph.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -55,7 +55,7 @@ extern int caml_gr_bits_per_pixel;
 #define DEFAULT_SCREEN_WIDTH 600
 #define DEFAULT_SCREEN_HEIGHT 450
 #define BORDER_WIDTH 2
-#define DEFAULT_WINDOW_NAME "Caml graphics"
+#define DEFAULT_WINDOW_NAME "OCaml graphics"
 #define DEFAULT_SELECTED_EVENTS \
             (ExposureMask | KeyPressMask | StructureNotifyMask)
 #define DEFAULT_FONT "fixed"

diff --git a/otherlibs/graph/make_img.c b/otherlibs/graph/make_img.c
index 325e6698dd5270f367ba2b24fadd2e264b30a72e..08628804f5b278f991a72fd218d551f81405449f 100644 (file)
--- a/otherlibs/graph/make_img.c
+++ b/otherlibs/graph/make_img.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c
index 82a4c0fb3bc738b387f1e1fda29f6fef97a23e35..1f7da5ba4f9d5ecc05b9d87d3caf746f03b3e317 100644 (file)
--- a/otherlibs/graph/open.c
+++ b/otherlibs/graph/open.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c
index 473dae7d08489777215612b940000bb979d5be0a..2149aa8eb1ca7f4fef4820cb6d3c15ea5ef732a7 100644 (file)
--- a/otherlibs/graph/point_col.c
+++ b/otherlibs/graph/point_col.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/sound.c b/otherlibs/graph/sound.c
index dc75b7ed034ab52535ec6cfd78efa0751fef0172..cba7a909ba674c1cdcfae4af84f56ecb56ce2995 100644 (file)
--- a/otherlibs/graph/sound.c
+++ b/otherlibs/graph/sound.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/subwindow.c b/otherlibs/graph/subwindow.c
index 642e28c40101925cc22bd89c01e929d03dd4346e..08882569e1e2920e0d0cfb89eda70a3bff5a264d 100644 (file)
--- a/otherlibs/graph/subwindow.c
+++ b/otherlibs/graph/subwindow.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*              Jun Furuse, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c
index f4d980aed5f752ac06b4da27441dd1c7be39fd08..6743e8640f8c7b3e56b809a96df9c9c4ee305943 100644 (file)
--- a/otherlibs/graph/text.c
+++ b/otherlibs/graph/text.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/labltk/.cvsignore b/otherlibs/labltk/.cvsignore
deleted file mode 100644 (file)
index f58b073..0000000
--- a/otherlibs/labltk/.cvsignore
+++ /dev/null
@@ -1,4 +0,0 @@
-labltklink
-labltkopt
-Makefile.config
-config.status

diff --git a/otherlibs/labltk/.ignore b/otherlibs/labltk/.ignore
new file mode 100644 (file)
index 0000000..f58b073
--- /dev/null
+++ b/otherlibs/labltk/.ignore
@@ -0,0 +1,4 @@
+labltklink
+labltkopt
+Makefile.config
+config.status

diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile
index 8c3b823c5ec488db8a0b9e5046cd1e6a07e3359b..8b7209b10f6d858b4c157e6170c8ad9ca1466856 100644 (file)
--- a/otherlibs/labltk/Makefile
+++ b/otherlibs/labltk/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 1999 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 # Top Makefile for mlTk
 
 SUBDIRS=compiler support lib jpf frx examples_labltk \

diff --git a/otherlibs/labltk/Makefile.nt b/otherlibs/labltk/Makefile.nt
index f1fd56ed95cc76f31ab9d5ff575e9d7e30ce8b58..651540f342e7a2c686cb1fb86c11bb6eb773a479 100644 (file)
--- a/otherlibs/labltk/Makefile.nt
+++ b/otherlibs/labltk/Makefile.nt
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2000 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 # Top Makefile for LablTk
 
 include ../../config/Makefile

diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README
index b556d2b3e81f99ec959a5f7b43ff0a6275ef7203..6815b6669dc0b01408524a9c9e81c72ce33eefea 100644 (file)
--- a/otherlibs/labltk/README
+++ b/otherlibs/labltk/README
@@ -1,6 +1,6 @@
 INTRODUCTION
 ============
-mlTk is a library for interfacing Objective Caml with the scripting
+mlTk is a library for interfacing OCaml with the scripting
 language Tcl/Tk (all versions since 8.0.3, but no betas).
 
 In addition to the basic interface with Tcl/Tk, this package contains
@@ -13,11 +13,11 @@ In addition to the basic interface with Tcl/Tk, this package contains
 
 mlTk = CamlTk + LablTk
 ======================
-There existed two parallel Tcl/Tk interfaces for O'Caml, CamlTk and LablTk.
+There existed two parallel Tcl/Tk interfaces for OCaml, CamlTk and LablTk.
 
 CamlTk uses classical features only, therefore it is easy to understand for
-the beginners of ML. It makes many conservative O'Caml gurus also happy.
-LablTk, on the other hand, uses rather newer features of O'Caml, the labeled
+the beginners of ML. It makes many conservative OCaml gurus also happy.
+LablTk, on the other hand, uses rather newer features of OCaml, the labeled
 optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk
 script flavor, but provides more powerful typing than CamlTk at the same time
 (i.e. less run time type checking of widgets).
@@ -31,7 +31,7 @@ just with little fixes.
 REQUIREMENTS
 ============
 You must have already installed
- * Objective Caml source, version 3.04+8 or later
+ * OCaml source, version 3.04+8 or later
 
  * Tcl/Tk 8.0.3 or later
     http://www.scriptics.com/ or various mirrors
@@ -44,9 +44,9 @@ OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin).
 INSTALLATION
 ============
 
-0. Check-out the O'Caml CVS source code tree.
+0. Check-out the OCaml CVS source code tree.
 
-1. Compile O'Caml (= make world). If you want, also make opt.
+1. Compile OCaml (= make world). If you want, also make opt.
 
 2. Untar this mlTk distribution in the otherlibs directory, just like
    the labltk source tree.
@@ -55,9 +55,9 @@ INSTALLATION
 
 4. To install the library, make install (and make installopt)
 
-To compile mlTk, you need the O'Caml source tree, since mltk/camlbrowser
-requires some modules of O'Caml. If you are not interested in camlbrowser,
-you can compile mlTk without the O'Caml source tree, but you have to modify
+To compile mlTk, you need the OCaml source tree, since mltk/camlbrowser
+requires some modules of OCaml. If you are not interested in camlbrowser,
+you can compile mlTk without the OCaml source tree, but you have to modify
 support/Makefile.common.
 
 

diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src
index abf015a275030506a69e3eaa5e474b58638b6b9e..e662682788d1b09e2d9f0fc6b9640eb1f3ebf60c 100644 (file)
--- a/otherlibs/labltk/Widgets.src
+++ b/otherlibs/labltk/Widgets.src
@@ -1,3 +1,19 @@
+%(***********************************************************************)
+%(*                                                                     *)
+%(*                 MLTk, Tcl/Tk interface of OCaml                     *)
+%(*                                                                     *)
+%(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
+%(*               projet Cristal, INRIA Rocquencourt                    *)
+%(*            Jacques Garrigue, Kyoto University RIMS                  *)
+%(*                                                                     *)
+%(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+%(*  en Automatique and Kyoto University.  All rights reserved.         *)
+%(*  This file is distributed under the terms of the GNU Library        *)
+%(*  General Public License, with the special exception on linking      *)
+%(*  described in file LICENSE found in the OCaml source tree.          *)
+%(*                                                                     *)
+%(***********************************************************************)
+
 %%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%%
 type Widget external
 

diff --git a/otherlibs/labltk/browser/.cvsignore b/otherlibs/labltk/browser/.cvsignore
deleted file mode 100644 (file)
index 8ced21d..0000000
--- a/otherlibs/labltk/browser/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-ocamlbrowser
-dummy.mli

diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend
index 4438a1dd83d73f85ae842e88abf0244564e0a844..4a0040b3b92eafcc7407734ce63a2d54db3674e8 100644 (file)
--- a/otherlibs/labltk/browser/.depend
+++ b/otherlibs/labltk/browser/.depend
@@ -1,66 +1,101 @@
-editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \
+editor.cmo : viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \
     searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \
     jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \
     fileselect.cmi editor.cmi
-editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \
+editor.cmx : viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \
     searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \
     jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \
     fileselect.cmx editor.cmi
-fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \
-    jg_entry.cmo jg_box.cmo fileselect.cmi
-fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \
-    jg_entry.cmx jg_box.cmx fileselect.cmi
-jg_bind.cmo: jg_bind.cmi
-jg_bind.cmx: jg_bind.cmi
-jg_box.cmo: jg_completion.cmi jg_bind.cmi
-jg_box.cmx: jg_completion.cmx jg_bind.cmx
-jg_completion.cmo: jg_completion.cmi
-jg_completion.cmx: jg_completion.cmi
-jg_config.cmo: jg_tk.cmo jg_config.cmi
-jg_config.cmx: jg_tk.cmx jg_config.cmi
-jg_entry.cmo: jg_bind.cmi
-jg_entry.cmx: jg_bind.cmx
-jg_memo.cmo: jg_memo.cmi
-jg_memo.cmx: jg_memo.cmi
-jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \
+fileselect.cmo : useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo \
+    jg_memo.cmi jg_entry.cmo jg_box.cmo fileselect.cmi
+fileselect.cmx : useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx \
+    jg_memo.cmx jg_entry.cmx jg_box.cmx fileselect.cmi
+help.cmo :
+help.cmx :
+jg_bind.cmo : jg_bind.cmi
+jg_bind.cmx : jg_bind.cmi
+jg_box.cmo : jg_completion.cmi jg_bind.cmi
+jg_box.cmx : jg_completion.cmx jg_bind.cmx
+jg_button.cmo :
+jg_button.cmx :
+jg_completion.cmo : jg_completion.cmi
+jg_completion.cmx : jg_completion.cmi
+jg_config.cmo : jg_tk.cmo jg_config.cmi
+jg_config.cmx : jg_tk.cmx jg_config.cmi
+jg_entry.cmo : jg_bind.cmi
+jg_entry.cmx : jg_bind.cmx
+jg_memo.cmo : jg_memo.cmi
+jg_memo.cmx : jg_memo.cmi
+jg_menu.cmo :
+jg_menu.cmx :
+jg_message.cmo : jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \
     jg_message.cmi
-jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \
+jg_message.cmx : jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \
     jg_message.cmi
-jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi
-jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi
-jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi
-jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi
-lexical.cmo: jg_tk.cmo lexical.cmi
-lexical.cmx: jg_tk.cmx lexical.cmi
-main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \
+jg_multibox.cmo : jg_completion.cmi jg_bind.cmi jg_multibox.cmi
+jg_multibox.cmx : jg_completion.cmx jg_bind.cmx jg_multibox.cmi
+jg_text.cmo : jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi \
+    jg_text.cmi
+jg_text.cmx : jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx \
+    jg_text.cmi
+jg_tk.cmo :
+jg_tk.cmx :
+jg_toplevel.cmo :
+jg_toplevel.cmx :
+lexical.cmo : jg_tk.cmo lexical.cmi
+lexical.cmx : jg_tk.cmx lexical.cmi
+list2.cmo :
+list2.cmx :
+main.cmo : viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \
     editor.cmi
-main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \
+main.cmx : viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \
     editor.cmx
-searchid.cmo: list2.cmo searchid.cmi
-searchid.cmx: list2.cmx searchid.cmi
-searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \
-    jg_memo.cmi jg_bind.cmi searchpos.cmi
-searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \
-    jg_memo.cmx jg_bind.cmx searchpos.cmi
-setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \
+searchid.cmo : list2.cmo searchid.cmi
+searchid.cmx : list2.cmx searchid.cmi
+searchpos.cmo : searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi \
+    jg_message.cmi jg_memo.cmi jg_bind.cmi searchpos.cmi
+searchpos.cmx : searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx \
+    jg_message.cmx jg_memo.cmx jg_bind.cmx searchpos.cmi
+setpath.cmo : useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \
     jg_bind.cmi setpath.cmi
-setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \
+setpath.cmx : useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \
     jg_bind.cmx setpath.cmi
-shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \
+shell.cmo : list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \
     jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi
-shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \
+shell.cmx : list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \
     jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi
-typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi
-typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi
-useunix.cmo: useunix.cmi
-useunix.cmx: useunix.cmi
-viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \
+typecheck.cmo : mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \
+    typecheck.cmi
+typecheck.cmx : mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx \
+    typecheck.cmi
+useunix.cmo : useunix.cmi
+useunix.cmx : useunix.cmi
+viewer.cmo : useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \
     mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \
     jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \
     jg_box.cmo jg_bind.cmi help.cmo viewer.cmi
-viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \
+viewer.cmx : useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \
     mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \
     jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \
     jg_box.cmx jg_bind.cmx help.cmx viewer.cmi
-mytypes.cmi: shell.cmi
-typecheck.cmi: mytypes.cmi
+dummy.cmi :
+dummyUnix.cmi :
+dummyWin.cmi :
+editor.cmi :
+fileselect.cmi :
+jg_bind.cmi :
+jg_completion.cmi :
+jg_config.cmi :
+jg_memo.cmi :
+jg_message.cmi :
+jg_multibox.cmi :
+jg_text.cmi :
+lexical.cmi :
+mytypes.cmi : shell.cmi
+searchid.cmi :
+searchpos.cmi :
+setpath.cmi :
+shell.cmi :
+typecheck.cmi : mytypes.cmi
+useunix.cmi :
+viewer.cmi :

diff --git a/otherlibs/labltk/browser/.ignore b/otherlibs/labltk/browser/.ignore
new file mode 100644 (file)
index 0000000..8d7632f
--- /dev/null
+++ b/otherlibs/labltk/browser/.ignore
@@ -0,0 +1,3 @@
+ocamlbrowser
+dummy.mli
+help.ml

diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile
index 5caed2bf600f2b0e971ef66ea0ad8c3990936dd5..a21973e7c54fded857d76224cc5f971035fc63e1 100644 (file)
--- a/otherlibs/labltk/browser/Makefile
+++ b/otherlibs/labltk/browser/Makefile
@@ -1,3 +1,17 @@
+#########################################################################
+#                                                                       #
+#                         OCaml LablTk library                          #
+#                                                                       #
+#            Jacques Garrigue, Kyoto University RIMS                    #
+#                                                                       #
+#   Copyright 1999 Institut National de Recherche en Informatique et    #
+#   en Automatique and Kyoto University.  All rights reserved.          #
+#   This file is distributed under the terms of the GNU Library         #
+#   General Public License, with the special exception on linking       #
+#   described in file ../../../LICENSE.                                 #
+#                                                                       #
+#########################################################################
+
 # $Id$
 
 OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str

diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt
index 405f47e74672a3b35592f26be330100c836540a5..289b0924c3beaf6f8a3f122d15882087b42ccd3c 100644 (file)
--- a/otherlibs/labltk/browser/Makefile.nt
+++ b/otherlibs/labltk/browser/Makefile.nt
@@ -1,3 +1,17 @@
+#########################################################################
+#                                                                       #
+#                         OCaml LablTk library                          #
+#                                                                       #
+#            Jacques Garrigue, Kyoto University RIMS                    #
+#                                                                       #
+#   Copyright 2000 Institut National de Recherche en Informatique et    #
+#   en Automatique and Kyoto University.  All rights reserved.          #
+#   This file is distributed under the terms of the GNU Library         #
+#   General Public License, with the special exception on linking       #
+#   described in file ../../../LICENSE.                                 #
+#                                                                       #
+#########################################################################
+
 # $Id$
 
 OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads

diff --git a/otherlibs/labltk/browser/Makefile.shared b/otherlibs/labltk/browser/Makefile.shared
index b80967086fbef4d47d49a5bf8d56cd6e30969ddb..35b8edf7f1c01c7dea613c018fd669e2ab99a3fc 100644 (file)
--- a/otherlibs/labltk/browser/Makefile.shared
+++ b/otherlibs/labltk/browser/Makefile.shared
@@ -1,5 +1,19 @@
 include ../support/Makefile.common
 
+#########################################################################
+#                                                                       #
+#                         OCaml LablTk library                          #
+#                                                                       #
+#            Jacques Garrigue, Kyoto University RIMS                    #
+#                                                                       #
+#   Copyright 1999 Institut National de Recherche en Informatique et    #
+#   en Automatique and Kyoto University.  All rights reserved.          #
+#   This file is distributed under the terms of the GNU Library         #
+#   General Public License, with the special exception on linking       #
+#   described in file ../../../LICENSE.                                 #
+#                                                                       #
+#########################################################################
+
 LABLTKLIB=-I ../labltk -I ../lib -I ../support
 OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing
 INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB)
@@ -9,7 +23,7 @@ OBJ =  list2.cmo       useunix.cmo     setpath.cmo     lexical.cmo     \
        help.cmo        \
        viewer.cmo      typecheck.cmo   editor.cmo      main.cmo
 
-JG =   jg_tk.cmo       jg_config.cmo   jg_bind.cmo      jg_completion.cmo \
+JG =   jg_tk.cmo       jg_config.cmo   jg_bind.cmo     jg_completion.cmo \
        jg_box.cmo \
        jg_button.cmo   jg_toplevel.cmo jg_text.cmo     jg_message.cmo \
        jg_menu.cmo     jg_entry.cmo    jg_multibox.cmo jg_memo.cmo
@@ -52,9 +66,9 @@ install:
          cp ocamlbrowser$(EXE) $(BINDIR); fi
 
 clean:
-       rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig *.$(O)
+       rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig *.$(O) help.ml
 
-depend:
+depend: help.ml
        $(CAMLDEP) *.ml *.mli > .depend
 
 shell.cmo: dummy.cmi

diff --git a/otherlibs/labltk/browser/dummyUnix.mli b/otherlibs/labltk/browser/dummyUnix.mli
index 2272419236de4a77f9878120458aeceb6f8d539c..137368118814576c51f1838a9046e5654793e6e0 100644 (file)
--- a/otherlibs/labltk/browser/dummyUnix.mli
+++ b/otherlibs/labltk/browser/dummyUnix.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/dummyWin.mli b/otherlibs/labltk/browser/dummyWin.mli
index a4b75ee37bb51ee79ff199790e0353f74fa4e514..3f8c26e63c26b9415e70fa62de881c50fbdb5dc7 100644 (file)
--- a/otherlibs/labltk/browser/dummyWin.mli
+++ b/otherlibs/labltk/browser/dummyWin.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml
index 617cdfa85567df3ed839bfe7b4634e0529f07626..a9f7e6eaced683a85ace5371748c545d09d98775 100644 (file)
--- a/otherlibs/labltk/browser/editor.ml
+++ b/otherlibs/labltk/browser/editor.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/editor.mli b/otherlibs/labltk/browser/editor.mli
index 665ee813f399ebf130f8acb9b5661fb9a322f270..2d5e90492a73c027024c163a110a7b74bfe7cdd9 100644 (file)
--- a/otherlibs/labltk/browser/editor.mli
+++ b/otherlibs/labltk/browser/editor.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml
index 22052b4237f3328a125082d4a25123f8ca609cbc..d62b8ba3cdf5dd283d7b8751c8b4da8c9de3d320 100644 (file)
--- a/otherlibs/labltk/browser/fileselect.ml
+++ b/otherlibs/labltk/browser/fileselect.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/fileselect.mli b/otherlibs/labltk/browser/fileselect.mli
index b723c626d522d9429a2af1c644a03dd7235a4229..ed10eaf68fb716364c0ab110fc7642403e3e2104 100644 (file)
--- a/otherlibs/labltk/browser/fileselect.mli
+++ b/otherlibs/labltk/browser/fileselect.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/help.ml b/otherlibs/labltk/browser/help.ml
deleted file mode 100644 (file)
index 632e762..0000000
--- a/otherlibs/labltk/browser/help.ml
+++ /dev/null
@@ -1,168 +0,0 @@
-let text = "\
-\032                         OCamlBrowser Help\n\
-\n\
-USE\n\
-\n\
-\032  OCamlBrowser is composed of three tools, the Editor, which allows\n\
-\032  one to edit/typecheck/analyse .mli and .ml files, the Viewer, to\n\
-\032  walk around compiled modules, and the Shell, to run an OCaml\n\
-\032  subshell. You may only have one instance of Editor and Viewer, but\n\
-\032  you may use several subshells.\n\
-\n\
-\032  As with the compiler, you may specify a different path for the\n\
-\032  standard library by setting OCAMLLIB. You may also extend the\n\
-\032  initial load path (only standard library by default) by using the\n\
-\032  -I command line option. The -nolabels, -rectypes and -w options are\n\
-\032  also accepted, and inherited by subshells.\n\
-\032  The -oldui options selects the old multi-window interface. The\n\
-\032  default is now more like Smalltalk's class browser.\n\
-\n\
-1) Viewer\n\
-\n\
-\032  This is the first window you get when you start OCamlBrowser.  It\n\
-\032  displays a search window, and the list of modules in the load path.\n\
-\032  At the top a row of menus.\n\
-\n\
-\032  File - Open and File - Editor give access to the editor.\n\
-\n\
-\032  File - Shell opens an OCaml shell.\n\
-\n\
-\032  View - Show all defs  displays the signature of the currently\n\
-\032  selected module.\n\
-\n\
-\032  View - Search entry  shows/hides the search entry just\n\
-\032  below the menu bar.\n\
-\n\
-\032  Modules - Path editor changes the load path.\n\
-\032       Pressing [Add to path] or Insert key adds selected directories\n\
-\032       to the load path.\n\
-\032       Pressing [Remove from path] or Delete key removes selected\n\
-\032       paths from the load path.\n\
-\n\
-\032  Modules - Reset cache rescans the load path and resets the module\n\
-\032  cache. Do it if you recompile some interface, or change the load\n\
-\032  path in a conflictual way.\n\
-\n\
-\032  Modules - Search symbol allows to search a symbol either by its\n\
-\032  name, like the bottom line of the viewer, or, more interestingly,\n\
-\032  by its type. Exact type searches for a type with exactly the same\n\
-\032  information as the pattern (variables match only variables),\n\
-\032  included type allows to give only partial information: the actual\n\
-\032  type may take more arguments and return more results, and variables\n\
-\032  in the pattern match anything. In both cases, argument and tuple\n\
-\032  order is irrelevant (*), and unlabeled arguments in the pattern\n\
-\032  match any label.\n\
-\n\
-\032  (*) To avoid combinatorial explosion of the search space, optional\n\
-\032  arguments in the actual type are ignored if (1) there are to many\n\
-\032  of them, and (2) they do not appear explicitly in the pattern.\n\
-\n\
-\032  The Search entry just below the menu bar allows one to search for\n\
-\032  an identifier in all modules, either by its name (? and * patterns\n\
-\032  allowed) or by its type (if there is an arrow in the input). When\n\
-\032  search by type is used, it is done in inclusion mode (cf. Modules -\n\
-\032  search symbol)\n\
-\n\
-\032  The Close all button is there to dismiss the windows created\n\
-\032  by the Detach button. By double-clicking on it you will quit the\n\
-\032  browser.\n\
-\n\
-\n\
-2) Module browsing\n\
-\n\
-\032  You select a module in the leftmost box by either cliking on it or\n\
-\032  pressing return when it is selected. Fast access is available in\n\
-\032  all boxes pressing the first few letter of the desired name.\n\
-\032  Double-clicking / double-return displays the whole signature for\n\
-\032  the module.\n\
-\n\
-\032  Defined identifiers inside the module are displayed in a box to the\n\
-\032  right of the previous one. If you click on one, this will either\n\
-\032  display its contents in another box (if this is a sub-module) or\n\
-\032  display the signature for this identifier below.\n\
-\n\
-\032  Signatures are clickable. Double clicking with the left mouse\n\
-\032  button on an identifier in a signature brings you to its signature,\n\
-\032  inside its module box.\n\
-\032  A single click on the right button pops up a menu displaying the\n\
-\032  type declaration for the selected identifier. Its title, when\n\
-\032  selectable, also brings you to its signature.\n\
-\n\
-\032  At the bottom, a series of buttons, depending on the context.\n\
-\032  * Detach copies the currently displayed signature in a new window,\n\
-\032    to keep it.\n\
-\032  * Impl and Intf bring you to the implementation or interface of\n\
-\032    the currently displayed signature, if it is available.\n\
-\n\
-\032  C-s opens a text search dialog for the displayed signature.\n\
-\n\
-3) File editor\n\
-\n\
-\032  You can edit files with it, but there is no auto-save nor undo at\n\
-\032  the moment. Otherwise you can use it as a browser, making\n\
-\032  occasional corrections.\n\
-\n\
-\032  The Edit menu contains commands for jump (C-g), search (C-s), and\n\
-\032  sending the current selection to a sub-shell (M-x). For this last\n\
-\032  option, you may choose the shell via a dialog.\n\
-\n\
-\032  Essential function are in the Compiler menu.\n\
-\n\
-\032  Preferences opens a dialog to set internals of the editor and\n\
-\032  type checker.\n\
-\n\
-\032  Lex (M-l) adds colors according to lexical categories.\n\
-\n\
-\032  Typecheck (M-t) verifies typing, and memorizes it to let one see an\n\
-\032  expression's type by double-clicking on it. This is also valid for\n\
-\032  interfaces. If an error occurs, the part of the interface preceding\n\
-\032  the error is computed.\n\
-\n\
-\032  After typechecking, pressing the right button pops up a menu giving\n\
-\032  the type of the pointed expression, and eventually allowing to\n\
-\032  follow some links.\n\
-\n\
-\032  Clear errors dismisses type checker error messages and warnings.\n\
-\n\
-\032  Signature shows the signature of the current file.\n\
-\n\
-4) Shell\n\
-\n\
-\032  When you create a shell, a dialog is presented to you, letting you\n\
-\032  choose which command you want to run, and the title of the shell\n\
-\032  (to choose it in the Editor).\n\
-\n\
-\032  You may change the default command by setting the OLABL environment\n\
-\032  variable.\n\
-\n\
-\032  The executed subshell is given the current load path.\n\
-\032  File: use a source file or load a bytecode file.\n\
-\032    You may also import the browser's path into the subprocess.\n\
-\032  History: M-p and M-n browse up and down.\n\
-\032  Signal: C-c interrupts and you can kill the subprocess.\n\
-\n\
-BUGS\n\
-\n\
-* When you quit the editor and some file was modified, a dialogue is\n\
-\032 displayed asking wether you want to really quit or not. But 1) if\n\
-\032 you quit directly from the viewer, there is no dialogue at all, and\n\
-\032 2) if you close from the window manager, the dialogue is displayed,\n\
-\032 but you cannot cancel the destruction... Beware.\n\
-\n\
-* When you run it through xon, the shell hangs at the first error. But\n\
-\032 its ok if you start ocamlbrowser from a remote shell...\n\
-\n\
-TODO\n\
-\n\
-* Complete cross-references.\n\
-\n\
-* Power up editor.\n\
-\n\
-* Add support for the debugger.\n\
-\n\
-* Make this a real programming environment, both for beginners an\n\
-\032 experimented users.\n\
-\n\
-\n\
-Bug reports and comments to <garrigue@kurims.kyoto-u.ac.jp>\n\
-";;

diff --git a/otherlibs/labltk/browser/help.txt b/otherlibs/labltk/browser/help.txt
index 62bfc5921186c65e2a550b6958e937315a459930..3b8c9b8655343979514ecc4f498dab8867b4c8c4 100644 (file)
--- a/otherlibs/labltk/browser/help.txt
+++ b/otherlibs/labltk/browser/help.txt
@@ -159,7 +159,7 @@ TODO
 
 * Add support for the debugger.
 
-* Make this a real programming environment, both for beginners an
+* Make this a real programming environment, both for beginners and
   experimented users.
 
 

diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml
index 2e3ec9870b82570aa14f39a122ac4d25dc868d4f..3fb854b096447b0141e01a482db7bb0b90493ed0 100644 (file)
--- a/otherlibs/labltk/browser/jg_bind.ml
+++ b/otherlibs/labltk/browser/jg_bind.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_bind.mli b/otherlibs/labltk/browser/jg_bind.mli
index e09c2ba460ffe0ae2aa7207f3d0ffddedfd087e7..70e323bee8a2bba9e21eaa56e6bd11f98e8acbd6 100644 (file)
--- a/otherlibs/labltk/browser/jg_bind.mli
+++ b/otherlibs/labltk/browser/jg_bind.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml
index 3675f4bfa81232acb14185d0916d95e4e8a35128..bc865f6d5b1f5fb8304947b79740a925033e63a3 100644 (file)
--- a/otherlibs/labltk/browser/jg_box.ml
+++ b/otherlibs/labltk/browser/jg_box.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_button.ml b/otherlibs/labltk/browser/jg_button.ml
index 11abd68aba93f4ee8df43806341da5cd532f9051..de8d3582b9be308a47972821274002836db34b98 100644 (file)
--- a/otherlibs/labltk/browser/jg_button.ml
+++ b/otherlibs/labltk/browser/jg_button.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_completion.ml b/otherlibs/labltk/browser/jg_completion.ml
index c93b099b3abe5876e141e9d481cd4bde76c9bbd6..a5457a65b718d67ae8f6555e482021d5de15e4f7 100644 (file)
--- a/otherlibs/labltk/browser/jg_completion.ml
+++ b/otherlibs/labltk/browser/jg_completion.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_completion.mli b/otherlibs/labltk/browser/jg_completion.mli
index 69c7a134c27b055b7e4515a95114ae8bf450fa34..40c2db3ceecb4245240cca0b5800cdf13d355106 100644 (file)
--- a/otherlibs/labltk/browser/jg_completion.mli
+++ b/otherlibs/labltk/browser/jg_completion.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_config.ml b/otherlibs/labltk/browser/jg_config.ml
index bce0e50e7604f417d0ac02dcdead019e6436d7b7..fbbd2ef1bb7565950c94820005ccc0d5ccc409a8 100644 (file)
--- a/otherlibs/labltk/browser/jg_config.ml
+++ b/otherlibs/labltk/browser/jg_config.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_config.mli b/otherlibs/labltk/browser/jg_config.mli
index 511e2b3a6781f50b8e7add3e25b855a606e08526..fdaab3fe1d3f69f200dfa53d303cf2a9e90d5519 100644 (file)
--- a/otherlibs/labltk/browser/jg_config.mli
+++ b/otherlibs/labltk/browser/jg_config.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml
index c09a273e822ab3e41a5152a60b8c52025b26e7cf..1f7aab751af235dd97904edc4829ba8ee0fe69fe 100644 (file)
--- a/otherlibs/labltk/browser/jg_entry.ml
+++ b/otherlibs/labltk/browser/jg_entry.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_memo.ml b/otherlibs/labltk/browser/jg_memo.ml
index e238929a0893a2220445b1d4dbc55525110e55b0..fb1c05efaf676c7955d55d4ae012f3488a4d8119 100644 (file)
--- a/otherlibs/labltk/browser/jg_memo.ml
+++ b/otherlibs/labltk/browser/jg_memo.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_memo.mli b/otherlibs/labltk/browser/jg_memo.mli
index 5491dee32f1b5168c95a139f5e9c232fb36b7fdf..14443ad16a1e14da502d62842bd854d4fa54fe8a 100644 (file)
--- a/otherlibs/labltk/browser/jg_memo.mli
+++ b/otherlibs/labltk/browser/jg_memo.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml
index b399d10d8709a7c7328d095f164ed61c702539cb..880ca775e7b51a35950e5d9992bf1c805bb31339 100644 (file)
--- a/otherlibs/labltk/browser/jg_menu.ml
+++ b/otherlibs/labltk/browser/jg_menu.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml
index 3c18f193c4b70edc3b4faf239ce3deab7d3a797f..d4d3ebbd264481968af2cd0455389e1881db4b8a 100644 (file)
--- a/otherlibs/labltk/browser/jg_message.ml
+++ b/otherlibs/labltk/browser/jg_message.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_message.mli b/otherlibs/labltk/browser/jg_message.mli
index 0a83a594ff88a0a720cca2e65489177800589623..0e123ac2c72bb4f9c7bb5db1d937096a3a1543a1 100644 (file)
--- a/otherlibs/labltk/browser/jg_message.mli
+++ b/otherlibs/labltk/browser/jg_message.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml
index febec8e5de510d580dc7f55d54b8b662373d5e30..39082e329d61ead0fba7821c138675e92a09a8f6 100644 (file)
--- a/otherlibs/labltk/browser/jg_multibox.ml
+++ b/otherlibs/labltk/browser/jg_multibox.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_multibox.mli b/otherlibs/labltk/browser/jg_multibox.mli
index 6dfe7d8fb3fa7409bfc0644ef0e5f0028f28968e..bccca506257c42811507f7affd98dd433ce6c36b 100644 (file)
--- a/otherlibs/labltk/browser/jg_multibox.mli
+++ b/otherlibs/labltk/browser/jg_multibox.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_text.ml b/otherlibs/labltk/browser/jg_text.ml
index 067b9dac551bb76afa06c29ba4ceaa3794cb06a1..76eeb92a74cacc03137d6e5d2c45d6551d9a68e1 100644 (file)
--- a/otherlibs/labltk/browser/jg_text.ml
+++ b/otherlibs/labltk/browser/jg_text.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_text.mli b/otherlibs/labltk/browser/jg_text.mli
index e8646dd9d1883461abc6d9db50bbdd3fa7983847..44cba0232a97f7b0d9b87923db0e562a960b918e 100644 (file)
--- a/otherlibs/labltk/browser/jg_text.mli
+++ b/otherlibs/labltk/browser/jg_text.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_tk.ml b/otherlibs/labltk/browser/jg_tk.ml
index 7fc77f096aa1ee6ef88fef80d9154a674170edad..16106eebff0da0c79e635ffa62c4e7402273a1fb 100644 (file)
--- a/otherlibs/labltk/browser/jg_tk.ml
+++ b/otherlibs/labltk/browser/jg_tk.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/jg_toplevel.ml b/otherlibs/labltk/browser/jg_toplevel.ml
index 64b6f54d7621addcdae46a08bec0eca331e79631..d77845df58f377fe87e8b7c9f165874bd0106eda 100644 (file)
--- a/otherlibs/labltk/browser/jg_toplevel.ml
+++ b/otherlibs/labltk/browser/jg_toplevel.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/lexical.ml b/otherlibs/labltk/browser/lexical.ml
index 72f1957ec09aaf237631a0c358297a0405d62731..a700f7286924e63fbbf7831135ee78b404967d55 100644 (file)
--- a/otherlibs/labltk/browser/lexical.ml
+++ b/otherlibs/labltk/browser/lexical.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/lexical.mli b/otherlibs/labltk/browser/lexical.mli
index 3be04d3246c8b2df34a26ba3e81c16703d5cbd40..52d09e35f57bc407cb908308aa9b8a5a29be919d 100644 (file)
--- a/otherlibs/labltk/browser/lexical.mli
+++ b/otherlibs/labltk/browser/lexical.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/list2.ml b/otherlibs/labltk/browser/list2.ml
index 87b88f496a19674d3c278b7f4a45bf5498e2eed3..4439e7410ea1006e6dd033505e3e98e1c4b42419 100644 (file)
--- a/otherlibs/labltk/browser/list2.ml
+++ b/otherlibs/labltk/browser/list2.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml
index 181506960a361ec0ede3024ed8f6f6bfe74b222c..1d79daa5474c85b72da085053abee6b0f37c3574 100644 (file)
--- a/otherlibs/labltk/browser/main.ml
+++ b/otherlibs/labltk/browser/main.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -49,7 +49,7 @@ let check ~spec argv =
 open Printf
 
 let print_version () =
-  printf "The Objective Caml browser, version %s\n" Sys.ocaml_version;
+  printf "The OCaml browser, version %s\n" Sys.ocaml_version;
   exit 0;
 ;;
 
@@ -106,7 +106,7 @@ let _ =
         (Printf.sprintf "%s\nPlease check that %s %s\nCurrent value is `%s'"
            "Couldn't initialize environment."
            (if is_win32 then "%OCAMLLIB%" else "$OCAMLLIB")
-           "points to the Objective Caml library."
+           "points to the OCaml library."
            Config.standard_library)
   end;
 

diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli
index 6db120adccabb5ed53af1895890a9860cac4d93d..b4deead236364a5991ae96f50c610cfc7f78d02d 100644 (file)
--- a/otherlibs/labltk/browser/mytypes.mli
+++ b/otherlibs/labltk/browser/mytypes.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index 2848143904d1db5b5a3a16d4d09107f9e70988f2..e624eca982c0838493762e95da641e4e060a9dbc 100644 (file)
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -101,7 +101,7 @@ let rec all_args ty =
 
 let rec equal ~prefix t1 t2 =
   match (repr t1).desc, (repr t2).desc with
-    Tvar, Tvar -> true
+    Tvar _, Tvar _ -> true
   | Tvariant row1, Tvariant row2 ->
       let row1 = row_repr row1 and row2 = row_repr row2 in
       let fields1 = filter_row_fields false row1.row_fields
@@ -144,7 +144,7 @@ let get_options = List.filter ~f:is_opt
 
 let rec included ~prefix t1 t2 =
   match (repr t1).desc, (repr t2).desc with
-    Tvar, _ -> true
+    Tvar _, _ -> true
   | Tvariant row1, Tvariant row2 ->
       let row1 = row_repr row1 and row2 = row_repr row2 in
       let fields1 = filter_row_fields false row1.row_fields
@@ -222,6 +222,7 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
           if matches vd.val_type then [lid_of_id id, Pvalue] else []
       | Tsig_type (id, td, _) ->
           if
+          matches (newconstr (Pident id) td.type_params) ||
           begin match td.type_manifest with
             None -> false
           | Some t -> matches t
@@ -229,13 +230,17 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
           begin match td.type_kind with
             Type_abstract -> false
           | Type_variant l ->
-            List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches)
+            List.exists l ~f:
+            begin fun (_, l, r) ->
+              List.exists l ~f:matches ||
+              match r with None -> false | Some x -> matches x
+            end
           | Type_record(l, rep) ->
             List.exists l ~f:(fun (_, _, t) -> matches t)
           end
           then [lid_of_id id, Ptype] else []
       | Tsig_exception (id, l) ->
-          if List.exists l ~f:matches
+          if List.exists l.exn_args ~f:matches
           then [lid_of_id id, Pconstructor]
           else []
       | Tsig_module (id, Tmty_signature sign, _) ->
@@ -406,7 +411,7 @@ open Parsetree
 
 let rec bound_variables pat =
   match pat.ppat_desc with
-    Ppat_any | Ppat_constant _ | Ppat_type _ -> []
+    Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> []
   | Ppat_var s -> [s]
   | Ppat_alias (pat,s) -> s :: bound_variables pat
   | Ppat_tuple l -> List2.flat_map l ~f:bound_variables

diff --git a/otherlibs/labltk/browser/searchid.mli b/otherlibs/labltk/browser/searchid.mli
index 980c141d086fc2487c43c5e0df74025b8d09a9d5..9e0c8ad98981cd4625c96da2d5d1b8020ab6ea3f 100644 (file)
--- a/otherlibs/labltk/browser/searchid.mli
+++ b/otherlibs/labltk/browser/searchid.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 8cae9959302aa21d08fa9922ff363081c6738c02..2d4b689477b2a1d8c04e43019c91aa32104f8507 100644 (file)
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -170,7 +170,7 @@ let search_pos_type_decl td ~pos ~env =
       Ptype_abstract -> ()
     | Ptype_variant dl ->
         List.iter dl
-          ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
+          ~f:(fun (_, tl, _, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
     | Ptype_record dl ->
         List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
     search_tkind td.ptype_kind;
@@ -397,6 +397,7 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign =
           match e with
             Syntaxerr.Unclosed(l,_,_,_) -> l
           | Syntaxerr.Applicative_path l -> l
+          | Syntaxerr.Variable_in_scope(l,_) -> l
           | Syntaxerr.Other l -> l
         in
         Jg_text.tag_and_see  tw ~start:(tpos l.loc_start.Lexing.pos_cnum)
@@ -495,7 +496,8 @@ and view_expr_type ?title ?path ?env ?(name="noname") t =
     | Some path -> parent_path path, ident_of_path path ~default:name
   in
   view_signature ~title ?path ?env
-    [Tsig_value (id, {val_type = t; val_kind = Val_reg})]
+    [Tsig_value (id, {val_type = t; val_kind = Val_reg;
+                      val_loc = Location.none})]
 
 and view_decl lid ~kind ~env =
   match kind with
@@ -692,13 +694,6 @@ and search_pos_class_structure ~pos cls =
       | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
       | Cf_val _ -> ()
       | Cf_meth (_, exp) -> search_pos_expr exp ~pos
-      | Cf_let (_, pel, iel) ->
-          List.iter pel ~f:
-            begin fun (pat, exp) ->
-              search_pos_pat pat ~pos ~env:exp.exp_env;
-              search_pos_expr exp ~pos
-            end;
-          List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
       | Cf_init exp -> search_pos_expr exp ~pos
     end
 

diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli
index b2f89cd81c2528564496edda93ae8fbd109e8b8e..a2d5dfd9578f13746b509b0e6257b1532ee02641 100644 (file)
--- a/otherlibs/labltk/browser/searchpos.mli
+++ b/otherlibs/labltk/browser/searchpos.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml
index 1a41b573b58571afe8348c33240b9a9e9adf4b97..018657610b5d8f87fc5abd87c9ea89a91a0d44b4 100644 (file)
--- a/otherlibs/labltk/browser/setpath.ml
+++ b/otherlibs/labltk/browser/setpath.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/setpath.mli b/otherlibs/labltk/browser/setpath.mli
index 22bf5dc58303374beb9080f5dfe3a207c9b38a44..6191b70c60e2d2bd749f6d48d19ca005f47047c7 100644 (file)
--- a/otherlibs/labltk/browser/setpath.mli
+++ b/otherlibs/labltk/browser/setpath.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml
index 1f1492de99e1491dfc37cf91d2a1cc1761be336c..93525f8814c1428b5b24887ab3afe492ad779e43 100644 (file)
--- a/otherlibs/labltk/browser/shell.ml
+++ b/otherlibs/labltk/browser/shell.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/shell.mli b/otherlibs/labltk/browser/shell.mli
index ac94f43d7c213e4a8e96ab20eafba470221686a1..5bb1ff5a3d97b2191c65a555ce7902b78a2ac976 100644 (file)
--- a/otherlibs/labltk/browser/shell.mli
+++ b/otherlibs/labltk/browser/shell.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml
index d5347ef53bd4b44128db057ad2e7766eeef6abf2..ac861a6f2c5cd2e869c0eb82b575c7d8264af123 100644 (file)
--- a/otherlibs/labltk/browser/typecheck.ml
+++ b/otherlibs/labltk/browser/typecheck.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -60,8 +60,7 @@ let parse_pp ~parse ~wrap ~ext text =
       let ic = open_in_bin tmpfile in
       let ast =
         try
-          let buffer = String.create (String.length ast_magic) in
-          really_input ic buffer 0 (String.length ast_magic);
+          let buffer = Misc.input_bytes ic (String.length ast_magic) in
           if buffer = ast_magic then begin
             ignore (input_value ic);
             wrap (input_value ic)
@@ -73,7 +72,7 @@ let parse_pp ~parse ~wrap ~ext text =
           Outdated_version ->
             close_in ic;
             Sys.remove tmpfile;
-            failwith "Ocaml and preprocessor have incompatible versions"
+            failwith "OCaml and preprocessor have incompatible versions"
         | _ ->
             seek_in ic 0;
             let buffer = Lexing.from_channel ic in
@@ -140,6 +139,7 @@ let f txt =
           begin match err with
             Syntaxerr.Unclosed(l,_,_,_) -> l
           | Syntaxerr.Applicative_path l -> l
+          | Syntaxerr.Variable_in_scope(l,_) -> l
           | Syntaxerr.Other l -> l
           end
       | Typecore.Error (l,err) ->

diff --git a/otherlibs/labltk/browser/typecheck.mli b/otherlibs/labltk/browser/typecheck.mli
index d61fce62e34aac82727bf6c22ae8e324863c8076..08a16dd20c48a22e91a229d96187c6f808899bb8 100644 (file)
--- a/otherlibs/labltk/browser/typecheck.mli
+++ b/otherlibs/labltk/browser/typecheck.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/useunix.ml b/otherlibs/labltk/browser/useunix.ml
index 666f866f0254408c25f2d10cecaf1798b998b419..86554d48844e493538fb7ecdf6d1d3b7b27fdd21 100644 (file)
--- a/otherlibs/labltk/browser/useunix.ml
+++ b/otherlibs/labltk/browser/useunix.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/useunix.mli b/otherlibs/labltk/browser/useunix.mli
index 2850c0d2dad69a2772758b82230c98157734888e..47d7a26aa55c1337d34052fa5937669eeecfbf80 100644 (file)
--- a/otherlibs/labltk/browser/useunix.mli
+++ b/otherlibs/labltk/browser/useunix.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
index fef3cbe1045d70c4d962e65da24246a3b496be63..72b9c1d66ae2cba4050586d8ad1f908d495624a2 100644 (file)
--- a/otherlibs/labltk/browser/viewer.ml
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)
@@ -74,7 +74,7 @@ let view_symbol ~kind ~env ?path id =
         Tconstr (cpath, _, _) ->
         if Path.same cpath Predef.path_exn then
           view_signature ~title:(string_of_longident id) ~env ?path
-            [Tsig_exception (Ident.create name, cd.cstr_args)]
+            [Tsig_exception (Ident.create name, {exn_loc = Location.none; exn_args = cd.cstr_args})]
         else
           view_type_decl cpath ~env
       | _ -> ()

diff --git a/otherlibs/labltk/browser/viewer.mli b/otherlibs/labltk/browser/viewer.mli
index d8bec671df78bf64cac1269bb0887b46912073be..c56c5e415e053d4c51c5b8313a952c3fa8e36663 100644 (file)
--- a/otherlibs/labltk/browser/viewer.mli
+++ b/otherlibs/labltk/browser/viewer.mli
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*            Jacques Garrigue, Kyoto University RIMS                    *)
 (*                                                                       *)

diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c
index dd9146fcceb9c111790779ef54d52bf0a2e267ca..4dd0644168620ab3d7db4ec5045e9544d0dd9d1d 100644 (file)
--- a/otherlibs/labltk/browser/winmain.c
+++ b/otherlibs/labltk/browser/winmain.c
@@ -1,3 +1,17 @@
+/*************************************************************************/
+/*                                                                       */
+/*                         OCaml LablTk library                          */
+/*                                                                       */
+/*            Jacques Garrigue, Kyoto University RIMS                    */
+/*                                                                       */
+/*   Copyright 2001 Institut National de Recherche en Informatique et    */
+/*   en Automatique and Kyoto University.  All rights reserved.          */
+/*   This file is distributed under the terms of the GNU Library         */
+/*   General Public License, with the special exception on linking       */
+/*   described in file ../../../LICENSE.                                 */
+/*                                                                       */
+/*************************************************************************/
+
 /* $Id$ */
 
 #include <windows.h>

diff --git a/otherlibs/labltk/builtin/LICENSE b/otherlibs/labltk/builtin/LICENSE
index c006f51d5cf88a0267542836ed41b721085180f2..dbad5f1c066e536c9bba90b80ea330b256c98d99 100644 (file)
--- a/otherlibs/labltk/builtin/LICENSE
+++ b/otherlibs/labltk/builtin/LICENSE
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                Objective Caml LablTk library                          *)
+(*                         OCaml LablTk library                          *)
 (*                                                                       *)
 (*          Francois Rouaix, Francois Pessaux, Jun Furuse                *)
 (*               projet Cristal, INRIA Rocquencourt                      *)
@@ -16,4 +16,4 @@
 
 (* $Id$ *)
 
-All the files in this directory are subject to the above copyright notice.
\ No newline at end of file
+All the files in this directory are subject to the above copyright notice.

diff --git a/otherlibs/labltk/camltk/.cvsignore b/otherlibs/labltk/camltk/.cvsignore
deleted file mode 100644 (file)
index 5850676..0000000
--- a/otherlibs/labltk/camltk/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.ml *.mli labltktop labltk
-modules
-.depend

diff --git a/otherlibs/labltk/camltk/.ignore b/otherlibs/labltk/camltk/.ignore
new file mode 100644 (file)
index 0000000..81bd183
--- /dev/null
+++ b/otherlibs/labltk/camltk/.ignore
@@ -0,0 +1,4 @@
+*.ml
+*.mli
+labltktop
+labltk

diff --git a/otherlibs/labltk/camltk/Makefile b/otherlibs/labltk/camltk/Makefile
index 19300ead40f1e90302f6cb400becbe485b19799b..62c22d3af41d0a32175bf5f25539ec16f33dbf86 100644 (file)
--- a/otherlibs/labltk/camltk/Makefile
+++ b/otherlibs/labltk/camltk/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 COMPFLAGS= -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix

diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen
index f25e1f761298a730236e9a16affae5e872a80a3e..9ec1972c07563bec1fe5e556d28d725d92b8c382 100644 (file)
--- a/otherlibs/labltk/camltk/Makefile.gen
+++ b/otherlibs/labltk/camltk/Makefile.gen
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 all: cTk.ml camltk.ml .depend

diff --git a/otherlibs/labltk/camltk/modules b/otherlibs/labltk/camltk/modules
index c1a2eed857b35d2ebaa45955500e4a20e5b7996a..723783aa728b06dde8511fead0573692e616cc73 100644 (file)
--- a/otherlibs/labltk/camltk/modules
+++ b/otherlibs/labltk/camltk/modules
@@ -1,80 +1,80 @@
-CWIDGETOBJS=cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo 
-cPlace.ml cResource.ml cWm.ml cImagephoto.ml cCanvas.ml cButton.ml cText.ml cLabel.ml cScrollbar.ml cImage.ml cEncoding.ml cPixmap.ml cPalette.ml cFont.ml cMessage.ml cMenu.ml cEntry.ml cListbox.ml cFocus.ml cMenubutton.ml cPack.ml cOption.ml cToplevel.ml cFrame.ml cDialog.ml cImagebitmap.ml cClipboard.ml cRadiobutton.ml cTkwait.ml cGrab.ml cSelection.ml cScale.ml cOptionmenu.ml cWinfo.ml cGrid.ml cCheckbutton.ml cBell.ml cTkvars.ml : _tkgen.ml
+CWIDGETOBJS=cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo 
+cBell.ml cScale.ml cWinfo.ml cScrollbar.ml cEntry.ml cListbox.ml cWm.ml cTkwait.ml cGrab.ml cFont.ml cCanvas.ml cImage.ml cClipboard.ml cLabel.ml cResource.ml cMessage.ml cText.ml cImagephoto.ml cOption.ml cFrame.ml cSelection.ml cDialog.ml cPlace.ml cPixmap.ml cMenubutton.ml cRadiobutton.ml cFocus.ml cPack.ml cImagebitmap.ml cEncoding.ml cOptionmenu.ml cCheckbutton.ml cTkvars.ml cPalette.ml cMenu.ml cButton.ml cToplevel.ml cGrid.ml : _tkgen.ml
 
-cPlace.cmo : cPlace.ml
-cPlace.cmi : cPlace.mli
-cResource.cmo : cResource.ml
-cResource.cmi : cResource.mli
+cBell.cmo : cBell.ml
+cBell.cmi : cBell.mli
+cScale.cmo : cScale.ml
+cScale.cmi : cScale.mli
+cWinfo.cmo : cWinfo.ml
+cWinfo.cmi : cWinfo.mli
+cScrollbar.cmo : cScrollbar.ml
+cScrollbar.cmi : cScrollbar.mli
+cEntry.cmo : cEntry.ml
+cEntry.cmi : cEntry.mli
+cListbox.cmo : cListbox.ml
+cListbox.cmi : cListbox.mli
 cWm.cmo : cWm.ml
 cWm.cmi : cWm.mli
-cImagephoto.cmo : cImagephoto.ml
-cImagephoto.cmi : cImagephoto.mli
+cTkwait.cmo : cTkwait.ml
+cTkwait.cmi : cTkwait.mli
+cGrab.cmo : cGrab.ml
+cGrab.cmi : cGrab.mli
+cFont.cmo : cFont.ml
+cFont.cmi : cFont.mli
 cCanvas.cmo : cCanvas.ml
 cCanvas.cmi : cCanvas.mli
-cButton.cmo : cButton.ml
-cButton.cmi : cButton.mli
-cText.cmo : cText.ml
-cText.cmi : cText.mli
-cLabel.cmo : cLabel.ml
-cLabel.cmi : cLabel.mli
-cScrollbar.cmo : cScrollbar.ml
-cScrollbar.cmi : cScrollbar.mli
 cImage.cmo : cImage.ml
 cImage.cmi : cImage.mli
-cEncoding.cmo : cEncoding.ml
-cEncoding.cmi : cEncoding.mli
-cPixmap.cmo : cPixmap.ml
-cPixmap.cmi : cPixmap.mli
-cPalette.cmo : cPalette.ml
-cPalette.cmi : cPalette.mli
-cFont.cmo : cFont.ml
-cFont.cmi : cFont.mli
+cClipboard.cmo : cClipboard.ml
+cClipboard.cmi : cClipboard.mli
+cLabel.cmo : cLabel.ml
+cLabel.cmi : cLabel.mli
+cResource.cmo : cResource.ml
+cResource.cmi : cResource.mli
 cMessage.cmo : cMessage.ml
 cMessage.cmi : cMessage.mli
-cMenu.cmo : cMenu.ml
-cMenu.cmi : cMenu.mli
-cEntry.cmo : cEntry.ml
-cEntry.cmi : cEntry.mli
-cListbox.cmo : cListbox.ml
-cListbox.cmi : cListbox.mli
-cFocus.cmo : cFocus.ml
-cFocus.cmi : cFocus.mli
-cMenubutton.cmo : cMenubutton.ml
-cMenubutton.cmi : cMenubutton.mli
-cPack.cmo : cPack.ml
-cPack.cmi : cPack.mli
+cText.cmo : cText.ml
+cText.cmi : cText.mli
+cImagephoto.cmo : cImagephoto.ml
+cImagephoto.cmi : cImagephoto.mli
 cOption.cmo : cOption.ml
 cOption.cmi : cOption.mli
-cToplevel.cmo : cToplevel.ml
-cToplevel.cmi : cToplevel.mli
 cFrame.cmo : cFrame.ml
 cFrame.cmi : cFrame.mli
+cSelection.cmo : cSelection.ml
+cSelection.cmi : cSelection.mli
 cDialog.cmo : cDialog.ml
 cDialog.cmi : cDialog.mli
-cImagebitmap.cmo : cImagebitmap.ml
-cImagebitmap.cmi : cImagebitmap.mli
-cClipboard.cmo : cClipboard.ml
-cClipboard.cmi : cClipboard.mli
+cPlace.cmo : cPlace.ml
+cPlace.cmi : cPlace.mli
+cPixmap.cmo : cPixmap.ml
+cPixmap.cmi : cPixmap.mli
+cMenubutton.cmo : cMenubutton.ml
+cMenubutton.cmi : cMenubutton.mli
 cRadiobutton.cmo : cRadiobutton.ml
 cRadiobutton.cmi : cRadiobutton.mli
-cTkwait.cmo : cTkwait.ml
-cTkwait.cmi : cTkwait.mli
-cGrab.cmo : cGrab.ml
-cGrab.cmi : cGrab.mli
-cSelection.cmo : cSelection.ml
-cSelection.cmi : cSelection.mli
-cScale.cmo : cScale.ml
-cScale.cmi : cScale.mli
+cFocus.cmo : cFocus.ml
+cFocus.cmi : cFocus.mli
+cPack.cmo : cPack.ml
+cPack.cmi : cPack.mli
+cImagebitmap.cmo : cImagebitmap.ml
+cImagebitmap.cmi : cImagebitmap.mli
+cEncoding.cmo : cEncoding.ml
+cEncoding.cmi : cEncoding.mli
 cOptionmenu.cmo : cOptionmenu.ml
 cOptionmenu.cmi : cOptionmenu.mli
-cWinfo.cmo : cWinfo.ml
-cWinfo.cmi : cWinfo.mli
-cGrid.cmo : cGrid.ml
-cGrid.cmi : cGrid.mli
 cCheckbutton.cmo : cCheckbutton.ml
 cCheckbutton.cmi : cCheckbutton.mli
-cBell.cmo : cBell.ml
-cBell.cmi : cBell.mli
 cTkvars.cmo : cTkvars.ml
 cTkvars.cmi : cTkvars.mli
-camltk.cmo : cTk.cmo cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo cCheckbutton.cmo cBell.cmo cTkvars.cmo 
+cPalette.cmo : cPalette.ml
+cPalette.cmi : cPalette.mli
+cMenu.cmo : cMenu.ml
+cMenu.cmi : cMenu.mli
+cButton.cmo : cButton.ml
+cButton.cmi : cButton.mli
+cToplevel.cmo : cToplevel.ml
+cToplevel.cmi : cToplevel.mli
+cGrid.cmo : cGrid.ml
+cGrid.cmi : cGrid.mli
+camltk.cmo : cTk.cmo cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo 

diff --git a/otherlibs/labltk/compiler/.cvsignore b/otherlibs/labltk/compiler/.cvsignore
deleted file mode 100644 (file)
index 060114e..0000000
--- a/otherlibs/labltk/compiler/.cvsignore
+++ /dev/null
@@ -1,11 +0,0 @@
-lexer.ml
-parser.output
-parser.ml
-parser.mli
-tkcompiler
-pp
-copyright.ml
-pplex.ml
-ppyac.ml
-ppyac.output
-ppyac.mli

diff --git a/otherlibs/labltk/compiler/.ignore b/otherlibs/labltk/compiler/.ignore
new file mode 100644 (file)
index 0000000..060114e
--- /dev/null
+++ b/otherlibs/labltk/compiler/.ignore
@@ -0,0 +1,11 @@
+lexer.ml
+parser.output
+parser.ml
+parser.mli
+tkcompiler
+pp
+copyright.ml
+pplex.ml
+ppyac.ml
+ppyac.output
+ppyac.mli

diff --git a/otherlibs/labltk/compiler/Makefile b/otherlibs/labltk/compiler/Makefile
index b7db380f656006c81486555d05bc66b09a756f1a..f6e584546ef2c7ca7ca84b63c5a5bcf146d910d8 100644 (file)
--- a/otherlibs/labltk/compiler/Makefile
+++ b/otherlibs/labltk/compiler/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 1999 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 OBJS=  ../support/support.cmo flags.cmo copyright.cmo \

diff --git a/otherlibs/labltk/compiler/code.mli b/otherlibs/labltk/compiler/code.mli
index 6f3e292134377fd932969e70057f5685b37b0356..bde9c44554b0c113e436f34ee69eab363c9b22b9 100644 (file)
--- a/otherlibs/labltk/compiler/code.mli
+++ b/otherlibs/labltk/compiler/code.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml
index fd74bc173db51311c6d56c75fd09287f5f2f42e8..029cce70fb92efd836fef2df239bb3943b35c3cb 100644 (file)
--- a/otherlibs/labltk/compiler/compile.ml
+++ b/otherlibs/labltk/compiler/compile.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
@@ -548,7 +548,7 @@ let write_TKtoCAML ~w name ~def:typdef =
 (* Converters                 *)
 (******************************)
 
-(* Produce an in-lined converter Caml -> Tk for simple types *)
+(* Produce an in-lined converter OCaml -> Tk for simple types *)
 (* the converter is a function of type:  <type> -> string  *)
 let rec converterCAMLtoTK ~context_widget argname ty =
  match ty with

diff --git a/otherlibs/labltk/compiler/copyright b/otherlibs/labltk/compiler/copyright
index 23dff46dce2eb0a88df5c5c51c6f98e8c544944c..87ab0d30b0fff35ef512902c80f8c63697824af3 100644 (file)
--- a/otherlibs/labltk/compiler/copyright
+++ b/otherlibs/labltk/compiler/copyright
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,6 +10,6 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)

diff --git a/otherlibs/labltk/compiler/flags.ml b/otherlibs/labltk/compiler/flags.ml
index 009d5e725ac1cf205ee47ae555615b3465d97e95..d832b4947c8d9510c4d55872466159cbc6105a71 100644 (file)
--- a/otherlibs/labltk/compiler/flags.ml
+++ b/otherlibs/labltk/compiler/flags.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/intf.ml b/otherlibs/labltk/compiler/intf.ml
index 59608b381506760294ea6e3b4275fb65827f800f..42ad1b38da4ffe3d8dabfe0ed79d49ccf8137b41 100644 (file)
--- a/otherlibs/labltk/compiler/intf.ml
+++ b/otherlibs/labltk/compiler/intf.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/lexer.mll b/otherlibs/labltk/compiler/lexer.mll
index f51f0c01f310d057c991d6748d9ee0bf9d3ea29b..2fc2376e27078fcb0b4e7cd4ca1cf445a6e2bc2e 100644 (file)
--- a/otherlibs/labltk/compiler/lexer.mll
+++ b/otherlibs/labltk/compiler/lexer.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)

diff --git a/otherlibs/labltk/compiler/maincompile.ml b/otherlibs/labltk/compiler/maincompile.ml
index d8c72a312daea8c18b440270e369986e56900877..91b6bcdffb69e7928cfd537de55ef473231022e5 100644 (file)
--- a/otherlibs/labltk/compiler/maincompile.ml
+++ b/otherlibs/labltk/compiler/maincompile.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly
index 15ced65f8d0d49d90730ee2b62a47b692d016b70..6dc7aff329071f487ca5a25a1c3ae683071cd617 100644 (file)
--- a/otherlibs/labltk/compiler/parser.mly
+++ b/otherlibs/labltk/compiler/parser.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file ../LICENSE.                                      */
+/*  described in file ../../../LICENSE.                                */
 /*                                                                     */
 /***********************************************************************/
 

diff --git a/otherlibs/labltk/compiler/pp.ml b/otherlibs/labltk/compiler/pp.ml
index 5c46766af744d3082c7c13ab34acf69e2db31cec..c6d4f798730f1d6eef9ebe10487d14ece69e736f 100644 (file)
--- a/otherlibs/labltk/compiler/pp.ml
+++ b/otherlibs/labltk/compiler/pp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/ppexec.ml b/otherlibs/labltk/compiler/ppexec.ml
index 71118b9601f421151f21863d5d6c057b00cb27da..dd66928c74ffe2ad98bf870d3c42991238cc86eb 100644 (file)
--- a/otherlibs/labltk/compiler/ppexec.ml
+++ b/otherlibs/labltk/compiler/ppexec.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/pplex.mli b/otherlibs/labltk/compiler/pplex.mli
index 4eaa183b24cd22b8de4921b004cbc02829516b33..0502fc9019a9fe6aec1af5c8ac81ffc89a52297d 100644 (file)
--- a/otherlibs/labltk/compiler/pplex.mli
+++ b/otherlibs/labltk/compiler/pplex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/pplex.mll b/otherlibs/labltk/compiler/pplex.mll
index 313d1f2dd554b97a1844f36a403875c0fcb781f8..6559d8e94e2e0f2edeb38ceb9294930b8e35bcb8 100644 (file)
--- a/otherlibs/labltk/compiler/pplex.mll
+++ b/otherlibs/labltk/compiler/pplex.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file ../LICENSE.                                      *)
+(*  described in file ../../../LICENSE.                                *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/ppparse.ml b/otherlibs/labltk/compiler/ppparse.ml
index 630d675decc66b1134109691ee5480a3786d6d05..2b0fdbf8ca37ebd3dfa1c9febb775d5a6a9ebcc9 100644 (file)
--- a/otherlibs/labltk/compiler/ppparse.ml
+++ b/otherlibs/labltk/compiler/ppparse.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/ppyac.mly b/otherlibs/labltk/compiler/ppyac.mly
index da7ee681f21583b2e4ecec1be73b54493a88cc2a..f92ef966481db25939837b72cccfb3e16c3629aa 100644 (file)
--- a/otherlibs/labltk/compiler/ppyac.mly
+++ b/otherlibs/labltk/compiler/ppyac.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file ../LICENSE.                                      */
+/*  described in file ../../../LICENSE.                                */
 /*                                                                     */
 /***********************************************************************/
 

diff --git a/otherlibs/labltk/compiler/printer.ml b/otherlibs/labltk/compiler/printer.ml
index be70612aa2ee41d3a5cc6b81d0c537fd64dbdb67..fe33ada367589144ce65e501ad27a4ac60137540 100644 (file)
--- a/otherlibs/labltk/compiler/printer.ml
+++ b/otherlibs/labltk/compiler/printer.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/tables.ml b/otherlibs/labltk/compiler/tables.ml
index 0663dfaaddb8a223f40e6f382c5af3c06fbdd50a..a86b4af508f56a7fb5c4556ed965f9026a91b028 100644 (file)
--- a/otherlibs/labltk/compiler/tables.ml
+++ b/otherlibs/labltk/compiler/tables.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/compiler/tsort.ml b/otherlibs/labltk/compiler/tsort.ml
index 6496eaae2293174ed0ef217ab3cb077fd2e74e5b..6768d0d7fc1682e154597a09b01d5cd2a9fc152e 100644 (file)
--- a/otherlibs/labltk/compiler/tsort.ml
+++ b/otherlibs/labltk/compiler/tsort.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_camltk/.cvsignore b/otherlibs/labltk/examples_camltk/.cvsignore
deleted file mode 100644 (file)
index 801812f..0000000
--- a/otherlibs/labltk/examples_camltk/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-addition
-eyes
-fileinput
-fileopen
-helloworld
-tetris
-winskel
-mytext

diff --git a/otherlibs/labltk/examples_camltk/.ignore b/otherlibs/labltk/examples_camltk/.ignore
new file mode 100644 (file)
index 0000000..801812f
--- /dev/null
+++ b/otherlibs/labltk/examples_camltk/.ignore
@@ -0,0 +1,8 @@
+addition
+eyes
+fileinput
+fileopen
+helloworld
+tetris
+winskel
+mytext

diff --git a/otherlibs/labltk/examples_camltk/addition.ml b/otherlibs/labltk/examples_camltk/addition.ml
index d4b333dcd4de71fdaf67526f11a1a93caa065abf..44988370c2d439a2f4d2970c7a05aaa6078a8e97 100644 (file)
--- a/otherlibs/labltk/examples_camltk/addition.ml
+++ b/otherlibs/labltk/examples_camltk/addition.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml
index c9314623122662d6d7726f6635a32f543af829f6..b7636de42d8488ca62afe3995706cf28b4a77db5 100644 (file)
--- a/otherlibs/labltk/examples_camltk/eyes.ml
+++ b/otherlibs/labltk/examples_camltk/eyes.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,11 +10,11 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 
-(* The eyes of Caml (CamlTk) *)
+(* The eyes of OCaml (CamlTk) *)
 
 open Camltk;;
 

diff --git a/otherlibs/labltk/examples_camltk/fileinput.ml b/otherlibs/labltk/examples_camltk/fileinput.ml
index c6190bdd49a1ad9f4e4eff963eb1b21e60ee00e2..70bc675bf378a39af48cf7cfbf4f6d3ebf4a1fd0 100644 (file)
--- a/otherlibs/labltk/examples_camltk/fileinput.ml
+++ b/otherlibs/labltk/examples_camltk/fileinput.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk ;;

diff --git a/otherlibs/labltk/examples_camltk/fileopen.ml b/otherlibs/labltk/examples_camltk/fileopen.ml
index 927c24851e15e51c3134d5959a655b34625b5cbd..d0829bd2b239fe9fa0c5e2ae03c5cb212d08db98 100644 (file)
--- a/otherlibs/labltk/examples_camltk/fileopen.ml
+++ b/otherlibs/labltk/examples_camltk/fileopen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk;;

diff --git a/otherlibs/labltk/examples_camltk/helloworld.ml b/otherlibs/labltk/examples_camltk/helloworld.ml
index bb99d9dd54f75be30610baa39a350fd0b0f08987..9829fca84bf8afdbd55fa17ca1d7edcf506dea3e 100644 (file)
--- a/otherlibs/labltk/examples_camltk/helloworld.ml
+++ b/otherlibs/labltk/examples_camltk/helloworld.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk;;            (* Make interface functions available *)

diff --git a/otherlibs/labltk/examples_camltk/jptest.ml b/otherlibs/labltk/examples_camltk/jptest.ml
index 38d9694c3fd0102c02052616a39ad05ace01e761..9ec06acaae3856f7e22d90649878ed2138204a67 100644 (file)
--- a/otherlibs/labltk/examples_camltk/jptest.ml
+++ b/otherlibs/labltk/examples_camltk/jptest.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Tk

diff --git a/otherlibs/labltk/examples_camltk/mytext.ml b/otherlibs/labltk/examples_camltk/mytext.ml
index d4c0d00b0972221b71120a38ea3cc775a1cb737a..f3aadfbbec98a424c258bbc44be4f771f173f48c 100644 (file)
--- a/otherlibs/labltk/examples_camltk/mytext.ml
+++ b/otherlibs/labltk/examples_camltk/mytext.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/examples_camltk/socketinput.ml b/otherlibs/labltk/examples_camltk/socketinput.ml
index 492fdc926f7e066db9a60a28866f9512831b3298..485c258648d66afe81f1d10c3aa5c818a2236999 100644 (file)
--- a/otherlibs/labltk/examples_camltk/socketinput.ml
+++ b/otherlibs/labltk/examples_camltk/socketinput.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/examples_camltk/taddition.ml b/otherlibs/labltk/examples_camltk/taddition.ml
index 990812d730daf3dd09b0a9e5ef4d0703b05c5102..c186730303a6d86666252194392f685c730b794b 100644 (file)
--- a/otherlibs/labltk/examples_camltk/taddition.ml
+++ b/otherlibs/labltk/examples_camltk/taddition.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Tk

diff --git a/otherlibs/labltk/examples_camltk/tetris.ml b/otherlibs/labltk/examples_camltk/tetris.ml
index 835343475bafcdf8b350b9bdd9ac5db78f2f6ce1..14a9b648f33d826e03aa785898aa3f60c2d34c90 100644 (file)
--- a/otherlibs/labltk/examples_camltk/tetris.ml
+++ b/otherlibs/labltk/examples_camltk/tetris.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_camltk/text.ml b/otherlibs/labltk/examples_camltk/text.ml
index 35273377be3f826779897676a96b87c7ee421091..0f876337ff86b1e3a70cea46a32797a245d957e8 100644 (file)
--- a/otherlibs/labltk/examples_camltk/text.ml
+++ b/otherlibs/labltk/examples_camltk/text.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Tk

diff --git a/otherlibs/labltk/examples_camltk/winskel.ml b/otherlibs/labltk/examples_camltk/winskel.ml
index cf68178ae199cd0b238f552f4fbc51d88e4e499e..c83e6436843dd7b87ea94b6e3c526d21a77f072d 100644 (file)
--- a/otherlibs/labltk/examples_camltk/winskel.ml
+++ b/otherlibs/labltk/examples_camltk/winskel.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* This examples is based on Ousterhout's book (fig 16.15) *)

diff --git a/otherlibs/labltk/examples_labltk/.cvsignore b/otherlibs/labltk/examples_labltk/.cvsignore
deleted file mode 100644 (file)
index c1f6ec6..0000000
--- a/otherlibs/labltk/examples_labltk/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-calc
-clock
-demo
-eyes
-hello
-tetris
-lang
-taquin

diff --git a/otherlibs/labltk/examples_labltk/.ignore b/otherlibs/labltk/examples_labltk/.ignore
new file mode 100644 (file)
index 0000000..c1f6ec6
--- /dev/null
+++ b/otherlibs/labltk/examples_labltk/.ignore
@@ -0,0 +1,8 @@
+calc
+clock
+demo
+eyes
+hello
+tetris
+lang
+taquin

diff --git a/otherlibs/labltk/examples_labltk/calc.ml b/otherlibs/labltk/examples_labltk/calc.ml
index 088bf192f9f8f4e8862e7beabf6a997ea2a7edca..17a410c8d7b21664e4532b48621bb31f000a0ca5 100644 (file)
--- a/otherlibs/labltk/examples_labltk/calc.ml
+++ b/otherlibs/labltk/examples_labltk/calc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_labltk/clock.ml b/otherlibs/labltk/examples_labltk/clock.ml
index 57a59b825b8dfaeed15134779ab9fabbdb159900..6903acb21a8ce69c8189c2b02171f6e465890b53 100644 (file)
--- a/otherlibs/labltk/examples_labltk/clock.ml
+++ b/otherlibs/labltk/examples_labltk/clock.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_labltk/demo.ml b/otherlibs/labltk/examples_labltk/demo.ml
index bd36f3f3826ee00ca767147a879f66d5ba10f3e3..9524c1c7e09c7ad80e8c13fac2b6ee13b76eeaed 100644 (file)
--- a/otherlibs/labltk/examples_labltk/demo.ml
+++ b/otherlibs/labltk/examples_labltk/demo.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_labltk/eyes.ml b/otherlibs/labltk/examples_labltk/eyes.ml
index 81f6aa4a2a5742d8a26940f31b6724c7d124617e..a96e08260a3ed251fe2163519d1730b2cfc9497c 100644 (file)
--- a/otherlibs/labltk/examples_labltk/eyes.ml
+++ b/otherlibs/labltk/examples_labltk/eyes.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_labltk/hello.ml b/otherlibs/labltk/examples_labltk/hello.ml
index 3f39d546d2cb01e9de04c39f88d35c337b49c505..838b50ffc381299e6556e9f9d51aceb98dadcbea 100644 (file)
--- a/otherlibs/labltk/examples_labltk/hello.ml
+++ b/otherlibs/labltk/examples_labltk/hello.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_labltk/lang.ml b/otherlibs/labltk/examples_labltk/lang.ml
index cde36399183c0ec1116e75d02423e992f32e0e2a..0d6ba8c9cc106032f39295a3b4aafd4fbd34c582 100644 (file)
--- a/otherlibs/labltk/examples_labltk/lang.ml
+++ b/otherlibs/labltk/examples_labltk/lang.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_labltk/taquin.ml b/otherlibs/labltk/examples_labltk/taquin.ml
index 28099351810313c387815c0f7bba952a055f4d67..616f38cb46aa3b48528cde99eef6757b34521630 100644 (file)
--- a/otherlibs/labltk/examples_labltk/taquin.ml
+++ b/otherlibs/labltk/examples_labltk/taquin.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/examples_labltk/tetris.ml b/otherlibs/labltk/examples_labltk/tetris.ml
index 4f401e59240e98b82d0cd33ef49f25f9ed4edfdd..8260fc20595061458f42fb2b052b87994d51dadf 100644 (file)
--- a/otherlibs/labltk/examples_labltk/tetris.ml
+++ b/otherlibs/labltk/examples_labltk/tetris.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/frx/.cvsignore b/otherlibs/labltk/frx/.cvsignore
deleted file mode 100644 (file)
index 10301e2..0000000
--- a/otherlibs/labltk/frx/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.a

diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile
index 192034cf5d2495fca7d6f18bed541db8455ec992..581200b0789f6cd453bd34ecb0bd52c79c95f7d7 100644 (file)
--- a/otherlibs/labltk/frx/Makefile
+++ b/otherlibs/labltk/frx/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 COMPFLAGS=-I ../camltk -I ../support

diff --git a/otherlibs/labltk/frx/frx_after.ml b/otherlibs/labltk/frx/frx_after.ml
index 7fe6a4f2a554bd9f723158b6838ecf3151d7a2a7..1b7dfef8bd3aa51150ffd05e457a4916bc2e17de 100644 (file)
--- a/otherlibs/labltk/frx/frx_after.ml
+++ b/otherlibs/labltk/frx/frx_after.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Protocol

diff --git a/otherlibs/labltk/frx/frx_after.mli b/otherlibs/labltk/frx/frx_after.mli
index 73c07f7bb9a09e4c90a94adfaab1561770067426..45e30456c406ff5740966d7658cf1b56aebaabf9 100644 (file)
--- a/otherlibs/labltk/frx/frx_after.mli
+++ b/otherlibs/labltk/frx/frx_after.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val idle : (unit -> unit) -> unit

diff --git a/otherlibs/labltk/frx/frx_color.ml b/otherlibs/labltk/frx/frx_color.ml
index 140e138792ecd200d0a3581d1ca695d568f491f3..e3e616a98ec01c2cfd821d33fa41408f34ede061 100644 (file)
--- a/otherlibs/labltk/frx/frx_color.ml
+++ b/otherlibs/labltk/frx/frx_color.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_color.mli b/otherlibs/labltk/frx/frx_color.mli
index 513cb08394a437a9e44098b3fcad1ae77a9d591f..b2791655a5dc63de12a0baa9b72e99e28bce7b62 100644 (file)
--- a/otherlibs/labltk/frx/frx_color.mli
+++ b/otherlibs/labltk/frx/frx_color.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val check : string -> bool

diff --git a/otherlibs/labltk/frx/frx_ctext.ml b/otherlibs/labltk/frx/frx_ctext.ml
index 7d3cbb15af4f6bc9eb25565bd24c01b14b26c8b2..498fe8ec7811679b4097fc6b840e784d7c5bfc4e 100644 (file)
--- a/otherlibs/labltk/frx/frx_ctext.ml
+++ b/otherlibs/labltk/frx/frx_ctext.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* A trick by Steve Ball to do pixel scrolling on text widgets *)

diff --git a/otherlibs/labltk/frx/frx_ctext.mli b/otherlibs/labltk/frx/frx_ctext.mli
index e539f5a8bcf28f630de2b41f022347bf7479a697..2f696abea1fec784b07d414cf0fdb3287321a4d2 100644 (file)
--- a/otherlibs/labltk/frx/frx_ctext.mli
+++ b/otherlibs/labltk/frx/frx_ctext.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_dialog.ml b/otherlibs/labltk/frx/frx_dialog.ml
index 12289de638f44d5c3a4579627561ee25b4eaebbb..096812dbc61a876397854aeecd5a09b6d882297e 100644 (file)
--- a/otherlibs/labltk/frx/frx_dialog.ml
+++ b/otherlibs/labltk/frx/frx_dialog.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_dialog.mli b/otherlibs/labltk/frx/frx_dialog.mli
index cd256acb3e67f0f8bd4ac95e118c7d4c9360c79d..fd816d34c2775e5c5d81827569c11ede9589edae 100644 (file)
--- a/otherlibs/labltk/frx/frx_dialog.mli
+++ b/otherlibs/labltk/frx/frx_dialog.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_entry.ml b/otherlibs/labltk/frx/frx_entry.ml
index ec842218625f6b79947e24e2eac5886a91341776..0b7c339a0229ec665721f98f8a5e3f3eb8a39346 100644 (file)
--- a/otherlibs/labltk/frx/frx_entry.ml
+++ b/otherlibs/labltk/frx/frx_entry.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_entry.mli b/otherlibs/labltk/frx/frx_entry.mli
index 2f34a7e64c9825b1137065d1a9ed47fb1e69dfd0..0b09f16d3d2a17e8fa8552e90f88ec18f80472b3 100644 (file)
--- a/otherlibs/labltk/frx/frx_entry.mli
+++ b/otherlibs/labltk/frx/frx_entry.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_fileinput.ml b/otherlibs/labltk/frx/frx_fileinput.ml
index de136867032c72068c75d4f45766843f80a6a910..dfba7a0f82d96bcad5ec6887e6489f765ffc33cb 100644 (file)
--- a/otherlibs/labltk/frx/frx_fileinput.ml
+++ b/otherlibs/labltk/frx/frx_fileinput.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_fillbox.ml b/otherlibs/labltk/frx/frx_fillbox.ml
index 611b55a5dfa219f4a22e528597764b4682ecde30..143bea4a2121d137c41eb7972a52c78af206c5bb 100644 (file)
--- a/otherlibs/labltk/frx/frx_fillbox.ml
+++ b/otherlibs/labltk/frx/frx_fillbox.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_fillbox.mli b/otherlibs/labltk/frx/frx_fillbox.mli
index a825524cdc569315d354bb9b305e7c42b3c1a875..9cfc9e780bdfcb00a0cca3e0879d289e470e58b3 100644 (file)
--- a/otherlibs/labltk/frx/frx_fillbox.mli
+++ b/otherlibs/labltk/frx/frx_fillbox.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_fit.ml b/otherlibs/labltk/frx/frx_fit.ml
index c03d6997a78926557ab3f2b597d527fed95f0205..bcfd457a2e3a7c47214391887ecf923bcd5c8876 100644 (file)
--- a/otherlibs/labltk/frx/frx_fit.ml
+++ b/otherlibs/labltk/frx/frx_fit.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_fit.mli b/otherlibs/labltk/frx/frx_fit.mli
index 29479d801330a5d28966398a34f845a22b1bb6d5..e6149645531981c0cb5b33e110696bc8e89d31cf 100644 (file)
--- a/otherlibs/labltk/frx/frx_fit.mli
+++ b/otherlibs/labltk/frx/frx_fit.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_focus.ml b/otherlibs/labltk/frx/frx_focus.ml
index ce855e201f4ce53930bf3ff74bdb5b8047d9f19f..29eba574d8c381b1ccf954af74971da70e5b70ff 100644 (file)
--- a/otherlibs/labltk/frx/frx_focus.ml
+++ b/otherlibs/labltk/frx/frx_focus.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_focus.mli b/otherlibs/labltk/frx/frx_focus.mli
index 919f7047547fb2c8eaf78c798f6a7ca928f12135..dcb9317f8dbe6ab91a29d1a9c80210b57eb489b2 100644 (file)
--- a/otherlibs/labltk/frx/frx_focus.mli
+++ b/otherlibs/labltk/frx/frx_focus.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_font.ml b/otherlibs/labltk/frx/frx_font.ml
index 3b739a6507cea2d028b982310d9de5d6c134a00c..4acb59979ea654e17b425393239b54445dc4d5b8 100644 (file)
--- a/otherlibs/labltk/frx/frx_font.ml
+++ b/otherlibs/labltk/frx/frx_font.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_font.mli b/otherlibs/labltk/frx/frx_font.mli
index 8dd99973777c912f938161ac5be7af3d61a3419d..4ed235f4ce10f5ebf1c0a313b868ffe5b11177ca 100644 (file)
--- a/otherlibs/labltk/frx/frx_font.mli
+++ b/otherlibs/labltk/frx/frx_font.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val find : string -> string -> string -> int -> string

diff --git a/otherlibs/labltk/frx/frx_group.ml b/otherlibs/labltk/frx/frx_group.ml
index 17c8a0310d4d6d579fd1c5d1cd48e3547deb88fb..1adc2d8804c2589c510bf9b182f98feef1e4588f 100644 (file)
--- a/otherlibs/labltk/frx/frx_group.ml
+++ b/otherlibs/labltk/frx/frx_group.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_lbutton.ml b/otherlibs/labltk/frx/frx_lbutton.ml
index c4d51f7b595aca1c8bf5c1dda35a268a5948889d..82ea8a8cc90df6e3f6ba2750aa668f6dcea9fdec 100644 (file)
--- a/otherlibs/labltk/frx/frx_lbutton.ml
+++ b/otherlibs/labltk/frx/frx_lbutton.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_lbutton.mli b/otherlibs/labltk/frx/frx_lbutton.mli
index 60c26a5b512b7840240258ecdbbe078257ff4f5c..5522e5c24884278af8903273f73407017010ad4d 100644 (file)
--- a/otherlibs/labltk/frx/frx_lbutton.mli
+++ b/otherlibs/labltk/frx/frx_lbutton.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Widget

diff --git a/otherlibs/labltk/frx/frx_listbox.ml b/otherlibs/labltk/frx/frx_listbox.ml
index 17d6a3f9ae460cb7dbd7a815782a54804ec7a153..6d04262b698f412919280b0a343fba604b0cc492 100644 (file)
--- a/otherlibs/labltk/frx/frx_listbox.ml
+++ b/otherlibs/labltk/frx/frx_listbox.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_listbox.mli b/otherlibs/labltk/frx/frx_listbox.mli
index b44b6ee9d39dcfc8547687ab24ae0b5afbb06c00..54e7ec6a72c6bfac79a2bd6f8855418f28fd5eab 100644 (file)
--- a/otherlibs/labltk/frx/frx_listbox.mli
+++ b/otherlibs/labltk/frx/frx_listbox.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_mem.ml b/otherlibs/labltk/frx/frx_mem.ml
index 37af208306d4c0d554e6b4a3cedea2307d5f796e..6df0da75f17db284d840c98a9ac5bdab9d8d34c2 100644 (file)
--- a/otherlibs/labltk/frx/frx_mem.ml
+++ b/otherlibs/labltk/frx/frx_mem.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Memory gauge *)

diff --git a/otherlibs/labltk/frx/frx_mem.mli b/otherlibs/labltk/frx/frx_mem.mli
index f3069ec28bf79f74a89b60bec50eb0b99aa25a0a..190297b5e82c7282b34141973ad6e4bcdc9a075a 100644 (file)
--- a/otherlibs/labltk/frx/frx_mem.mli
+++ b/otherlibs/labltk/frx/frx_mem.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,10 +10,10 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
-(* A Garbage Collector Gauge for Caml *)
+(* A Garbage Collector Gauge for OCaml *)
 
 val init : unit -> unit
   (* [init ()] creates the gauge and its updater, but keeps it iconified *)

diff --git a/otherlibs/labltk/frx/frx_misc.ml b/otherlibs/labltk/frx/frx_misc.ml
index 75c8a3e4dfa820a6ef78b41d7281b51146938e6b..e45c5f0f03a0102a791619d01fa6543c9ab039bb 100644 (file)
--- a/otherlibs/labltk/frx/frx_misc.ml
+++ b/otherlibs/labltk/frx/frx_misc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Delayed global, a.k.a cache&carry *)

diff --git a/otherlibs/labltk/frx/frx_misc.mli b/otherlibs/labltk/frx/frx_misc.mli
index 2df8ce3d20c6ecf7ca80177d979d01af58876652..cd3d589fa1e387420c57f021b2f50034b5017dc9 100644 (file)
--- a/otherlibs/labltk/frx/frx_misc.mli
+++ b/otherlibs/labltk/frx/frx_misc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_req.ml b/otherlibs/labltk/frx/frx_req.ml
index ab7308fa36a6f95421a30c53b5753e7c6c37d4a0..41590c14515d972bfbe7c1e9ccca0825bb2f9c8a 100644 (file)
--- a/otherlibs/labltk/frx/frx_req.ml
+++ b/otherlibs/labltk/frx/frx_req.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_req.mli b/otherlibs/labltk/frx/frx_req.mli
index 41de7df35aef74557c58b5ffa8d97673093b786b..62985b9f90f0089860073a300431cbcc6a4ed509 100644 (file)
--- a/otherlibs/labltk/frx/frx_req.mli
+++ b/otherlibs/labltk/frx/frx_req.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Various dialog boxes *)

diff --git a/otherlibs/labltk/frx/frx_rpc.ml b/otherlibs/labltk/frx/frx_rpc.ml
index 5f29cbce5d369c1e52ac1d8eca79e10de4f0aaf8..5de7a15de7157192c92953de6d906894904d9e43 100644 (file)
--- a/otherlibs/labltk/frx/frx_rpc.ml
+++ b/otherlibs/labltk/frx/frx_rpc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Some notion of RPC *)

diff --git a/otherlibs/labltk/frx/frx_rpc.mli b/otherlibs/labltk/frx/frx_rpc.mli
index 808fe87c756e9e684f9cd74dc48fa673e46eb780..20811738a5bd73ec01a77f221b3d2a0a8593d392 100644 (file)
--- a/otherlibs/labltk/frx/frx_rpc.mli
+++ b/otherlibs/labltk/frx/frx_rpc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Some notion of RPC *)

diff --git a/otherlibs/labltk/frx/frx_selection.ml b/otherlibs/labltk/frx/frx_selection.ml
index 7ef64ce8601dfedc8496c3203e3f1449e00f98ea..ad037ce2d809936b4a2f1f03e1c05d5233d012fb 100644 (file)
--- a/otherlibs/labltk/frx/frx_selection.ml
+++ b/otherlibs/labltk/frx/frx_selection.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* A selection handler *)

diff --git a/otherlibs/labltk/frx/frx_selection.mli b/otherlibs/labltk/frx/frx_selection.mli
index dfb27ee249a75097b413d58ba770d62837c443a1..b15265834b341e8d446f57ac761be3cddef9d1d0 100644 (file)
--- a/otherlibs/labltk/frx/frx_selection.mli
+++ b/otherlibs/labltk/frx/frx_selection.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val set : string -> unit

diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml
index 76b83b640f2ac4127faa8148d3a2ac0541e393dc..21bd7fa86e9b46c18c8f9b9147d6c7ddfd5fbca5 100644 (file)
--- a/otherlibs/labltk/frx/frx_synth.ml
+++ b/otherlibs/labltk/frx/frx_synth.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Some notion of synthetic events *)

diff --git a/otherlibs/labltk/frx/frx_synth.mli b/otherlibs/labltk/frx/frx_synth.mli
index 0b8d85d85ee315211714ed47c775482947ba63f7..e5a96aa85fcd3bedf0f9146b1482722f383c6dbb 100644 (file)
--- a/otherlibs/labltk/frx/frx_synth.mli
+++ b/otherlibs/labltk/frx/frx_synth.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* Synthetic events *)

diff --git a/otherlibs/labltk/frx/frx_text.ml b/otherlibs/labltk/frx/frx_text.ml
index 18d9961ffc4ccd1c267ca5e8f57b1e0f178ba5b1..a9ca17a3722a13feadf3026182f6724688a42ac7 100644 (file)
--- a/otherlibs/labltk/frx/frx_text.ml
+++ b/otherlibs/labltk/frx/frx_text.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_text.mli b/otherlibs/labltk/frx/frx_text.mli
index ac0384432305e54a0bbc6ca1a5eda7395fc04547..97783fa96d2ca744278321ac4349f22e42d587b0 100644 (file)
--- a/otherlibs/labltk/frx/frx_text.mli
+++ b/otherlibs/labltk/frx/frx_text.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_toplevel.mli b/otherlibs/labltk/frx/frx_toplevel.mli
index 3608e1e578eb3abaca7f73fbe23ad0fc1b2757b0..628cde207809a2c352945a681486178bf3c48ccc 100644 (file)
--- a/otherlibs/labltk/frx/frx_toplevel.mli
+++ b/otherlibs/labltk/frx/frx_toplevel.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Widget

diff --git a/otherlibs/labltk/frx/frx_widget.ml b/otherlibs/labltk/frx/frx_widget.ml
index a81c768f015ad90f704835fc23be025c4f21d884..9045134361cc6af1e0ff22446364b3035387ef64 100644 (file)
--- a/otherlibs/labltk/frx/frx_widget.ml
+++ b/otherlibs/labltk/frx/frx_widget.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/frx/frx_widget.mli b/otherlibs/labltk/frx/frx_widget.mli
index ff26749ca238c737981798227f1fb1ef77add5e2..f856664cf3bf5936b855fd94e1e82e5ed0546db3 100644 (file)
--- a/otherlibs/labltk/frx/frx_widget.mli
+++ b/otherlibs/labltk/frx/frx_widget.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Camltk

diff --git a/otherlibs/labltk/jpf/.cvsignore b/otherlibs/labltk/jpf/.cvsignore
deleted file mode 100644 (file)
index 10301e2..0000000
--- a/otherlibs/labltk/jpf/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.a

diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile
index a79b3d5683452af237f9f9624a5f0e11fe00bf53..a768b1390aa5db687bb43a3b97609bf8aa2e1b5f 100644 (file)
--- a/otherlibs/labltk/jpf/Makefile
+++ b/otherlibs/labltk/jpf/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 1999 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix -I $(OTHERS)/str

diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml
index 739a8d9ece84487d7af2fdf12df1e0890b6a7ccc..e880f27774513cde4c2e786915af8e784fefa14b 100644 (file)
--- a/otherlibs/labltk/jpf/balloon.ml
+++ b/otherlibs/labltk/jpf/balloon.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/jpf/balloon.mli b/otherlibs/labltk/jpf/balloon.mli
index 633796ce6b8e77c9de57230013adb4082902e7bc..f3e65269da953796f6eb300ff0304d94718d6981 100644 (file)
--- a/otherlibs/labltk/jpf/balloon.mli
+++ b/otherlibs/labltk/jpf/balloon.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/jpf/balloontest.ml b/otherlibs/labltk/jpf/balloontest.ml
index 60e3aded38c1c21ab15456c72462638153f6f0cf..236f6174bffe6f1a21f2a637e137a6c9b54b3f48 100644 (file)
--- a/otherlibs/labltk/jpf/balloontest.ml
+++ b/otherlibs/labltk/jpf/balloontest.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml
index 3d42ac2dc1e1927300d5bed9b7c986252e687e80..23aaeb6d293c6135ac4d0e79021d3e55807fe312 100644 (file)
--- a/otherlibs/labltk/jpf/fileselect.ml
+++ b/otherlibs/labltk/jpf/fileselect.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/jpf/fileselect.mli b/otherlibs/labltk/jpf/fileselect.mli
index 4412a41875f4a9a0a91ba24bf50690a0e42bf2dd..42f7d34fa3b70bf8f4d80db92f0c85d65861ab90 100644 (file)
--- a/otherlibs/labltk/jpf/fileselect.mli
+++ b/otherlibs/labltk/jpf/fileselect.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/jpf/jpf_font.ml b/otherlibs/labltk/jpf/jpf_font.ml
index 24b87b7c06707ffddef351f30eebba1439d421d0..b036d421abd2e01c991a19eebea5e9d986defbbc 100644 (file)
--- a/otherlibs/labltk/jpf/jpf_font.ml
+++ b/otherlibs/labltk/jpf/jpf_font.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 (* find font information *)

diff --git a/otherlibs/labltk/jpf/jpf_font.mli b/otherlibs/labltk/jpf/jpf_font.mli
index 03f705f5291dd7cfb294d5719102959021d2c07f..f3045a9c8b7845fae6135a35a4d22e9320b31a41 100644 (file)
--- a/otherlibs/labltk/jpf/jpf_font.mli
+++ b/otherlibs/labltk/jpf/jpf_font.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val debug : bool ref

diff --git a/otherlibs/labltk/jpf/shell.ml b/otherlibs/labltk/jpf/shell.ml
index 8b00a8f2cf4a0b517af6df07e1f50ae9e4c17782..0d566e050e9aa11e5b1980f0fdf9fc9c69a323af 100644 (file)
--- a/otherlibs/labltk/jpf/shell.ml
+++ b/otherlibs/labltk/jpf/shell.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 open Unix

diff --git a/otherlibs/labltk/jpf/shell.mli b/otherlibs/labltk/jpf/shell.mli
index c3fec3a2e3e61c8048b95afb971b6a5468a1a27d..7c7dd8e1a0c32f43c15335fcd462f9a6b156b14d 100644 (file)
--- a/otherlibs/labltk/jpf/shell.mli
+++ b/otherlibs/labltk/jpf/shell.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 val subshell : string -> string list

diff --git a/otherlibs/labltk/labltk/.cvsignore b/otherlibs/labltk/labltk/.cvsignore
deleted file mode 100644 (file)
index 5850676..0000000
--- a/otherlibs/labltk/labltk/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.ml *.mli labltktop labltk
-modules
-.depend

diff --git a/otherlibs/labltk/labltk/.ignore b/otherlibs/labltk/labltk/.ignore
new file mode 100644 (file)
index 0000000..81bd183
--- /dev/null
+++ b/otherlibs/labltk/labltk/.ignore
@@ -0,0 +1,4 @@
+*.ml
+*.mli
+labltktop
+labltk

diff --git a/otherlibs/labltk/labltk/Makefile b/otherlibs/labltk/labltk/Makefile
index f678954e046df21ca6e1546e0dae5852a64cf044..1510de8f8ee7b674f49666e768d94d243fa3d0e4 100644 (file)
--- a/otherlibs/labltk/labltk/Makefile
+++ b/otherlibs/labltk/labltk/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 COMPFLAGS= -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix

diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen
index 592ea446235009ac4b052e78cd85f9d59f7fbf23..2e1fc274ee49f6a4928d570cbf9fd872069f4cab 100644 (file)
--- a/otherlibs/labltk/labltk/Makefile.gen
+++ b/otherlibs/labltk/labltk/Makefile.gen
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 all: tk.ml labltk.ml .depend

diff --git a/otherlibs/labltk/labltk/modules b/otherlibs/labltk/labltk/modules
index a17b6ab1ebc5bb3a06a4cf67aed7242776d4e91e..bb8d3e5b79e80670258c93ef5a0655942f811358 100644 (file)
--- a/otherlibs/labltk/labltk/modules
+++ b/otherlibs/labltk/labltk/modules
@@ -1,77 +1,77 @@
-WIDGETOBJS=place.cmo wm.cmo imagephoto.cmo canvas.cmo button.cmo text.cmo label.cmo scrollbar.cmo image.cmo encoding.cmo pixmap.cmo palette.cmo font.cmo message.cmo menu.cmo entry.cmo listbox.cmo focus.cmo menubutton.cmo pack.cmo option.cmo toplevel.cmo frame.cmo dialog.cmo imagebitmap.cmo clipboard.cmo radiobutton.cmo tkwait.cmo grab.cmo selection.cmo scale.cmo optionmenu.cmo winfo.cmo grid.cmo checkbutton.cmo bell.cmo tkvars.cmo 
-place.ml wm.ml imagephoto.ml canvas.ml button.ml text.ml label.ml scrollbar.ml image.ml encoding.ml pixmap.ml palette.ml font.ml message.ml menu.ml entry.ml listbox.ml focus.ml menubutton.ml pack.ml option.ml toplevel.ml frame.ml dialog.ml imagebitmap.ml clipboard.ml radiobutton.ml tkwait.ml grab.ml selection.ml scale.ml optionmenu.ml winfo.ml grid.ml checkbutton.ml bell.ml tkvars.ml : _tkgen.ml
+WIDGETOBJS=bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo 
+bell.ml scale.ml winfo.ml scrollbar.ml entry.ml listbox.ml wm.ml tkwait.ml grab.ml font.ml canvas.ml image.ml clipboard.ml label.ml message.ml text.ml imagephoto.ml option.ml frame.ml selection.ml dialog.ml place.ml pixmap.ml menubutton.ml radiobutton.ml focus.ml pack.ml imagebitmap.ml encoding.ml optionmenu.ml checkbutton.ml tkvars.ml palette.ml menu.ml button.ml toplevel.ml grid.ml : _tkgen.ml
 
-place.cmo : place.ml
-place.cmi : place.mli
+bell.cmo : bell.ml
+bell.cmi : bell.mli
+scale.cmo : scale.ml
+scale.cmi : scale.mli
+winfo.cmo : winfo.ml
+winfo.cmi : winfo.mli
+scrollbar.cmo : scrollbar.ml
+scrollbar.cmi : scrollbar.mli
+entry.cmo : entry.ml
+entry.cmi : entry.mli
+listbox.cmo : listbox.ml
+listbox.cmi : listbox.mli
 wm.cmo : wm.ml
 wm.cmi : wm.mli
-imagephoto.cmo : imagephoto.ml
-imagephoto.cmi : imagephoto.mli
+tkwait.cmo : tkwait.ml
+tkwait.cmi : tkwait.mli
+grab.cmo : grab.ml
+grab.cmi : grab.mli
+font.cmo : font.ml
+font.cmi : font.mli
 canvas.cmo : canvas.ml
 canvas.cmi : canvas.mli
-button.cmo : button.ml
-button.cmi : button.mli
-text.cmo : text.ml
-text.cmi : text.mli
-label.cmo : label.ml
-label.cmi : label.mli
-scrollbar.cmo : scrollbar.ml
-scrollbar.cmi : scrollbar.mli
 image.cmo : image.ml
 image.cmi : image.mli
-encoding.cmo : encoding.ml
-encoding.cmi : encoding.mli
-pixmap.cmo : pixmap.ml
-pixmap.cmi : pixmap.mli
-palette.cmo : palette.ml
-palette.cmi : palette.mli
-font.cmo : font.ml
-font.cmi : font.mli
+clipboard.cmo : clipboard.ml
+clipboard.cmi : clipboard.mli
+label.cmo : label.ml
+label.cmi : label.mli
 message.cmo : message.ml
 message.cmi : message.mli
-menu.cmo : menu.ml
-menu.cmi : menu.mli
-entry.cmo : entry.ml
-entry.cmi : entry.mli
-listbox.cmo : listbox.ml
-listbox.cmi : listbox.mli
-focus.cmo : focus.ml
-focus.cmi : focus.mli
-menubutton.cmo : menubutton.ml
-menubutton.cmi : menubutton.mli
-pack.cmo : pack.ml
-pack.cmi : pack.mli
+text.cmo : text.ml
+text.cmi : text.mli
+imagephoto.cmo : imagephoto.ml
+imagephoto.cmi : imagephoto.mli
 option.cmo : option.ml
 option.cmi : option.mli
-toplevel.cmo : toplevel.ml
-toplevel.cmi : toplevel.mli
 frame.cmo : frame.ml
 frame.cmi : frame.mli
+selection.cmo : selection.ml
+selection.cmi : selection.mli
 dialog.cmo : dialog.ml
 dialog.cmi : dialog.mli
-imagebitmap.cmo : imagebitmap.ml
-imagebitmap.cmi : imagebitmap.mli
-clipboard.cmo : clipboard.ml
-clipboard.cmi : clipboard.mli
+place.cmo : place.ml
+place.cmi : place.mli
+pixmap.cmo : pixmap.ml
+pixmap.cmi : pixmap.mli
+menubutton.cmo : menubutton.ml
+menubutton.cmi : menubutton.mli
 radiobutton.cmo : radiobutton.ml
 radiobutton.cmi : radiobutton.mli
-tkwait.cmo : tkwait.ml
-tkwait.cmi : tkwait.mli
-grab.cmo : grab.ml
-grab.cmi : grab.mli
-selection.cmo : selection.ml
-selection.cmi : selection.mli
-scale.cmo : scale.ml
-scale.cmi : scale.mli
+focus.cmo : focus.ml
+focus.cmi : focus.mli
+pack.cmo : pack.ml
+pack.cmi : pack.mli
+imagebitmap.cmo : imagebitmap.ml
+imagebitmap.cmi : imagebitmap.mli
+encoding.cmo : encoding.ml
+encoding.cmi : encoding.mli
 optionmenu.cmo : optionmenu.ml
 optionmenu.cmi : optionmenu.mli
-winfo.cmo : winfo.ml
-winfo.cmi : winfo.mli
-grid.cmo : grid.ml
-grid.cmi : grid.mli
 checkbutton.cmo : checkbutton.ml
 checkbutton.cmi : checkbutton.mli
-bell.cmo : bell.ml
-bell.cmi : bell.mli
 tkvars.cmo : tkvars.ml
 tkvars.cmi : tkvars.mli
+palette.cmo : palette.ml
+palette.cmi : palette.mli
+menu.cmo : menu.ml
+menu.cmi : menu.mli
+button.cmo : button.ml
+button.cmi : button.mli
+toplevel.cmo : toplevel.ml
+toplevel.cmi : toplevel.mli
+grid.cmo : grid.ml
+grid.cmi : grid.mli

diff --git a/otherlibs/labltk/lib/.cvsignore b/otherlibs/labltk/lib/.cvsignore
deleted file mode 100644 (file)
index 02d049a..0000000
--- a/otherlibs/labltk/lib/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-labltktop labltk mltktop mltk
-.depend
-*.ml
-*.mli
-modules
-labltk.cma
-labltk.cmxa
-*.a

diff --git a/otherlibs/labltk/lib/.ignore b/otherlibs/labltk/lib/.ignore
new file mode 100644 (file)
index 0000000..005295f
--- /dev/null
+++ b/otherlibs/labltk/lib/.ignore
@@ -0,0 +1,7 @@
+labltktop
+labltk
+mltktop
+mltk
+.depend
+*.ml
+*.mli

diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile
index b82bcddfafc8b570d8407d5d59635f337328da1b..35ba8ff680513750378d605f44b5a6bd143b4e84 100644 (file)
--- a/otherlibs/labltk/lib/Makefile
+++ b/otherlibs/labltk/lib/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 1999 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include ../support/Makefile.common
 
 all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME)
@@ -55,7 +71,7 @@ $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).$(A)
 $(LIBNAME): Makefile $(TOPDIR)/config/Makefile
        @echo Generate $@
        @echo "#!/bin/sh" > $@
-       @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@
+       @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) "$$@"' >> $@
 
 install-script: $(LIBNAME)
        cp $(LIBNAME) $(BINDIR)

diff --git a/otherlibs/labltk/support/.cvsignore b/otherlibs/labltk/support/.cvsignore
deleted file mode 100644 (file)
index 56d9c77..0000000
--- a/otherlibs/labltk/support/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-*.so
-*.a

diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile
index dd037a2b4b98ec0bfc5d229f21d2f38b7ee93e78..26f4c50f14ff8d87cbfc301717dafe0e9b4b3952 100644 (file)
--- a/otherlibs/labltk/support/Makefile
+++ b/otherlibs/labltk/support/Makefile
@@ -1,3 +1,19 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 1999 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 include Makefile.common
 
 all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \
@@ -16,9 +32,10 @@ CCFLAGS=-I../../../byterun $(TK_DEFS) $(SHAREDCCCOMPOPTS)
 
 COMPFLAGS=-I $(OTHERS)/win32unix -I $(OTHERS)/unix
 THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads
+TKLDOPTS=$(TK_LINK:%=-ldopt "%")
 
 lib$(LIBNAME).$(A): $(COBJS)
-       $(MKLIB) -o $(LIBNAME) $(COBJS) -ldopt "$(TK_LINK)"
+       $(MKLIB) -o $(LIBNAME) $(COBJS) $(TKLDOPTS)
 
 PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \
     rawwidget.mli widget.mli

diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common
index 56f6fd1377c705ab4ad74eca9f791b13fa6646c0..f0aa930d302765a068d11885b9aa87997d38aa98 100644 (file)
--- a/otherlibs/labltk/support/Makefile.common
+++ b/otherlibs/labltk/support/Makefile.common
@@ -1,5 +1,21 @@
+#######################################################################
+#                                                                     #
+#                 MLTk, Tcl/Tk interface of OCaml                     #
+#                                                                     #
+#    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    #
+#               projet Cristal, INRIA Rocquencourt                    #
+#            Jacques Garrigue, Kyoto University RIMS                  #
+#                                                                     #
+#  Copyright 1999 Institut National de Recherche en Informatique et   #
+#  en Automatique and Kyoto University.  All rights reserved.         #
+#  This file is distributed under the terms of the GNU Library        #
+#  General Public License, with the special exception on linking      #
+#  described in file LICENSE found in the OCaml source tree.          #
+#                                                                     #
+#######################################################################
+
 ## Paths are relative to subdirectories
-## Where you compiled Objective Caml
+## Where you compiled OCaml
 TOPDIR=../../..
 ## Path to the otherlibs subdirectory
 OTHERS=$(TOPDIR)/otherlibs
@@ -10,7 +26,7 @@ include $(TOPDIR)/config/Makefile
 
 INSTALLDIR=$(LIBDIR)/$(LIBNAME)
 
-## Tools from the Objective Caml distribution
+## Tools from the OCaml distribution
 
 CAMLRUN=$(TOPDIR)/boot/ocamlrun
 CAMLC=$(TOPDIR)/ocamlcomp.sh

diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h
index 5be206faa89674bcff234c3430c494c28ee74bde..29452aaccec00f432885f9533cdf9d66c4ff6af7 100644 (file)
--- a/otherlibs/labltk/support/camltk.h
+++ b/otherlibs/labltk/support/camltk.h
@@ -1,6 +1,6 @@
 /*************************************************************************/
 /*                                                                       */
-/*                Objective Caml LablTk library                          */
+/*                         OCaml LablTk library                          */
 /*                                                                       */
 /*         Francois Rouaix, Francois Pessaux and Jun Furuse              */
 /*               projet Cristal, INRIA Rocquencourt                      */
@@ -33,7 +33,7 @@
 #endif
 
 /* cltkMisc.c */
-/* copy a Caml string to the C heap. Must be deallocated with stat_free */
+/* copy an OCaml string to the C heap. Must be deallocated with stat_free */
 extern char *string_to_c(value s);
 
 /* cltkUtf.c */
@@ -45,7 +45,7 @@ CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */
 extern value copy_string_list(int argc, char **argv);
 
 /* cltkCaml.c */
-/* pointers to Caml values */
+/* pointers to OCaml values */
 extern value *tkerror_exn;
 extern value *handler_code;
 extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp,

diff --git a/otherlibs/labltk/support/camltkwrap.ml b/otherlibs/labltk/support/camltkwrap.ml
index 5b49b19f0fc04e894069e8b0192124a1870aedbf..635349a31562c1f0177c9db4a5dbd40cc57a81ac 100644 (file)
--- a/otherlibs/labltk/support/camltkwrap.ml
+++ b/otherlibs/labltk/support/camltkwrap.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 module Widget = struct

diff --git a/otherlibs/labltk/support/camltkwrap.mli b/otherlibs/labltk/support/camltkwrap.mli
index 1af566d2cd75beba71d941fab88c16728e89d207..4fc7e3c1590fc70a3969c355f95ff0e9a9690c44 100644 (file)
--- a/otherlibs/labltk/support/camltkwrap.mli
+++ b/otherlibs/labltk/support/camltkwrap.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 module Widget : sig

diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c
index c9bcc80dce1470df26fcfe9ac9fd4fe768d44a91..9a3d38a5505bd701a4485a336a3120dd3785e69c 100644 (file)
--- a/otherlibs/labltk/support/cltkCaml.c
+++ b/otherlibs/labltk/support/cltkCaml.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -27,7 +27,7 @@
 value * tkerror_exn = NULL;
 value * handler_code = NULL;
 
-/* The Tcl command for evaluating callback in Caml */
+/* The Tcl command for evaluating callback in OCaml */
 int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp,
               int argc, CONST84 char **argv)
 {
@@ -41,7 +41,7 @@ int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp,
       return TCL_ERROR;
     callback2(*handler_code,Val_int(id),
               copy_string_list(argc - 2,(char **)&argv[2]));
-    /* Never fails (Caml would have raised an exception) */
+    /* Never fails (OCaml would have raised an exception) */
     /* but result may have been set by callback */
     return TCL_OK;
   }
@@ -69,14 +69,14 @@ CAMLprim void tk_error(char *errmsg)
 }
 
 
-/* The initialisation of the C global variables pointing to Caml values
-   must be made accessible from Caml, so that we are sure that it *always*
+/* The initialisation of the C global variables pointing to OCaml values
+   must be made accessible from OCaml, so that we are sure that it *always*
    takes place during loading of the protocol module
  */
 
 CAMLprim value camltk_init(value v)
 {
-  /* Initialize the Caml pointers */
+  /* Initialize the OCaml pointers */
   if (tkerror_exn == NULL)
     tkerror_exn = caml_named_value("tkerror");
   if (handler_code == NULL)

diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c
index 3d9a4c2dfe9d057d851b53f7c7073e611dc582c9..04af209de37fe50aa16f108a1982bbd714abaab8 100644 (file)
--- a/otherlibs/labltk/support/cltkDMain.c
+++ b/otherlibs/labltk/support/cltkDMain.c
@@ -1,6 +1,6 @@
 /*************************************************************************/
 /*                                                                       */
-/*                Objective Caml LablTk library                          */
+/*                         OCaml LablTk library                          */
 /*                                                                       */
 /*         Francois Rouaix, Francois Pessaux and Jun Furuse              */
 /*               projet Cristal, INRIA Rocquencourt                      */
@@ -35,7 +35,7 @@
 
 
 /*
- * Dealing with signals: when a signal handler is defined in Caml,
+ * Dealing with signals: when a signal handler is defined in OCaml,
  * the actual execution of the signal handler upon reception of the
  * signal is delayed until we are sure we are out of the GC.
  * If a signal occurs during the MainLoop, we would have to wait

diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c
index cdd16a914a895416e58fb59d0b68c2842a860a87..69ba6d8a176bfa41201e7cebe4a7ff119ca452db 100644 (file)
--- a/otherlibs/labltk/support/cltkEval.c
+++ b/otherlibs/labltk/support/cltkEval.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -32,7 +32,7 @@
 /* The Tcl interpretor */
 Tcl_Interp *cltclinterp = NULL;
 
-/* Copy a list of strings from the C heap to Caml */
+/* Copy a list of strings from the C heap to OCaml */
 value copy_string_list(int argc, char **argv)
 {
   CAMLparam0();
@@ -53,7 +53,7 @@ value copy_string_list(int argc, char **argv)
 }
 
 /*
- * Calling Tcl from Caml
+ * Calling Tcl from OCaml
  *   this version works on an arbitrary Tcl command,
  *   and does parsing and substitution
  */
@@ -65,7 +65,7 @@ CAMLprim value camltk_tcl_eval(value str)
   CheckInit();
 
   /* Tcl_Eval may write to its argument, so we take a copy
-   * If the evaluation raises a Caml exception, we have a space
+   * If the evaluation raises an OCaml exception, we have a space
    * leak
    */
   Tcl_ResetResult(cltclinterp);
@@ -84,7 +84,7 @@ CAMLprim value camltk_tcl_eval(value str)
 }
 
 /*
- * Calling Tcl from Caml
+ * Calling Tcl from OCaml
  *   direct call, argument is TkArgs vect
   type TkArgs =
       TkToken of string
@@ -142,7 +142,7 @@ int fill_args (char **argv, int where, value v)
       tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
       fill_args(tmpargv,0,Field(v,0));
       tmpargv[size] = NULL;
-      merged = Tcl_Merge(size,tmpargv);
+      merged = Tcl_Merge(size,(const char *const*)tmpargv);
       for(i = 0; i<size; i++){ stat_free(tmpargv[i]); }
       stat_free((char *)tmpargv);
       /* must be freed by stat_free */
@@ -207,17 +207,17 @@ CAMLprim value camltk_tcl_direct_eval(value v)
       result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf));
       Tcl_DStringFree(&buf);
     } else {
-      result = (*info.proc)(info.clientData,cltclinterp,size,argv);
+      result = (*info.proc)(info.clientData,cltclinterp,size,(const char**)argv);
     }
 #else
-    result = (*info.proc)(info.clientData,cltclinterp,size,argv);
+    result = (*info.proc)(info.clientData,cltclinterp,size,(const char**)argv);
 #endif
   } else { /* implement the autoload stuff */
     if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */
       for (i = size; i >= 0; i--)
         argv[i+1] = argv[i];
       argv[0] = "unknown";
-      result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
+      result = (*info.proc)(info.clientData,cltclinterp,size+1,(const char**)argv);
     } else { /* ah, it isn't there at all */
       result = TCL_ERROR;
       Tcl_AppendResult(cltclinterp, "Unknown command \"",

diff --git a/otherlibs/labltk/support/cltkEvent.c b/otherlibs/labltk/support/cltkEvent.c
index ad9b4d9edabb40c5f425af1c82cae106ee9c8e61..4507cf6943e726d7b647ad301dbada68d76e5012 100644 (file)
--- a/otherlibs/labltk/support/cltkEvent.c
+++ b/otherlibs/labltk/support/cltkEvent.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 

diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c
index 4fbf9868e61d9b5a3e534de0e988b7ddd937d201..b4ebca61444183563ca7bae21baffb657714ae99 100644 (file)
--- a/otherlibs/labltk/support/cltkFile.c
+++ b/otherlibs/labltk/support/cltkFile.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 

diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c
index d8d5dd3d07f4318628680b7fd65f86cf0fec6231..0a0fa17c5c5b5b41819d2141d2773ea3673e2662 100644 (file)
--- a/otherlibs/labltk/support/cltkImg.c
+++ b/otherlibs/labltk/support/cltkImg.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 #include <string.h>
@@ -90,7 +90,7 @@ camltk_setimgdata_native (value imgname, value pixmap, value x, value y,
     tk_error("no such image");
 #endif
 
-  pib.pixelPtr = String_val(pixmap);
+  pib.pixelPtr = (unsigned char *)String_val(pixmap);
   pib.width = Int_val(w);
   pib.height = Int_val(h);
   pib.pitch = pib.width * 3;

diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c
index eb4617a45de73f571fa19773c0cdbfb14cc028fe..8751334c515c782ad1ae0650d829a920d1c3462c 100644 (file)
--- a/otherlibs/labltk/support/cltkMain.c
+++ b/otherlibs/labltk/support/cltkMain.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -35,7 +35,7 @@
 #endif
 
 /*
- * Dealing with signals: when a signal handler is defined in Caml,
+ * Dealing with signals: when a signal handler is defined in OCaml,
  * the actual execution of the signal handler upon reception of the
  * signal is delayed until we are sure we are out of the GC.
  * If a signal occurs during the MainLoop, we would have to wait
@@ -125,7 +125,7 @@ CAMLprim value camltk_opentk(value argv)
 
         sprintf( argcstr, "%d", argc );
         Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY);
-        args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */
+        args = Tcl_Merge(argc, (const char *const*)tkargv); /* args must be freed by Tcl_Free */
         Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
         Tcl_Free(args);
         stat_free( tkargv );

diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c
index b19713cda79401bc12aa270610307f119eec64ce..a89ea341f195e9811fa1dfba32787a89073950b3 100644 (file)
--- a/otherlibs/labltk/support/cltkMisc.c
+++ b/otherlibs/labltk/support/cltkMisc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -35,7 +35,7 @@ CAMLprim value camltk_splitlist (value v)
 
   utf = caml_string_to_tcl(v);
   /* argv is allocated by Tcl, to be freed by us */
-  result = Tcl_SplitList(cltclinterp,utf,&argc,&argv);
+  result = Tcl_SplitList(cltclinterp,utf,&argc,(const char ***)&argv);
   switch(result) {
   case TCL_OK:
    { value res = copy_string_list(argc,argv);
@@ -51,7 +51,7 @@ CAMLprim value camltk_splitlist (value v)
   }
 }
 
-/* Copy a Caml string to the C heap. Should deallocate with stat_free */
+/* Copy an OCaml string to the C heap. Should deallocate with stat_free */
 char *string_to_c(value s)
 {
   int l = string_length(s);

diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c
index e0635e8501135a5f8e254e7ee228e20fb6b62a9e..afebef8e1d821a891301109063d87334aa8db98d 100644 (file)
--- a/otherlibs/labltk/support/cltkTimer.c
+++ b/otherlibs/labltk/support/cltkTimer.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -34,11 +34,11 @@ CAMLprim value camltk_add_timer(value milli, value cbid)
   CheckInit();
   /* look at tkEvent.c , Tk_Token is an int */
   return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc,
-                                       (ClientData) (Int_val(cbid)))));
+                                       (ClientData) (Long_val(cbid)))));
 }
 
 CAMLprim value camltk_rem_timer(value token)
 {
-  Tcl_DeleteTimerHandler((Tcl_TimerToken) Int_val(token));
+  Tcl_DeleteTimerHandler((Tcl_TimerToken) Long_val(token));
   return Val_unit;
 }

diff --git a/otherlibs/labltk/support/cltkUtf.c b/otherlibs/labltk/support/cltkUtf.c
index fd01bd15a4da4fb2b20ee1de67de2bc6a0da4251..448e06a1cfe5e2cddf4eed7d2104a19e8aabfd14 100644 (file)
--- a/otherlibs/labltk/support/cltkUtf.c
+++ b/otherlibs/labltk/support/cltkUtf.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 

diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c
index 0411a94cda36edfb33abe8c4a6f3eb92c79f2685..dcda8a77c15af320cf6fdedab27dfd78beb774e4 100644 (file)
--- a/otherlibs/labltk/support/cltkVar.c
+++ b/otherlibs/labltk/support/cltkVar.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 
@@ -33,13 +33,13 @@ CAMLprim value camltk_getvar(value var)
   CheckInit();
 
   stable_var = string_to_c(var);
-  s = Tcl_GetVar(cltclinterp,stable_var,
-                   TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
+  s = (char *)Tcl_GetVar(cltclinterp,stable_var,
+                         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
   stat_free(stable_var);
 
   if (s == NULL)
     tk_error(Tcl_GetStringResult(cltclinterp));
-  else 
+  else
     return(tcl_string_to_caml(s));
 }
 
@@ -51,12 +51,12 @@ CAMLprim value camltk_setvar(value var, value contents)
   CheckInit();
 
   /* SetVar makes a copy of the contents. */
-  /* In case we have write traces in Caml, it's better to make sure that
+  /* In case we have write traces in OCaml, it's better to make sure that
      var doesn't move... */
   stable_var = string_to_c(var);
   utf_contents = caml_string_to_tcl(contents);
-  s = Tcl_SetVar(cltclinterp,stable_var, utf_contents,
-                   TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
+  s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents,
+                         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
   stat_free(stable_var);
   if( s == utf_contents ){
     tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!");

diff --git a/otherlibs/labltk/support/cltkWait.c b/otherlibs/labltk/support/cltkWait.c
index 4c126b5d2086f96f1a437dd357e45e373349797c..a46860b85ce18050e88028f7dd72194c693bb8b9 100644 (file)
--- a/otherlibs/labltk/support/cltkWait.c
+++ b/otherlibs/labltk/support/cltkWait.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
+/*                 MLTk, Tcl/Tk interface of OCaml                     */
 /*                                                                     */
 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
 /*               projet Cristal, INRIA Rocquencourt                    */
@@ -10,7 +10,7 @@
 /*  en Automatique and Kyoto University.  All rights reserved.         */
 /*  This file is distributed under the terms of the GNU Library        */
 /*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
+/*  described in file LICENSE found in the OCaml source tree.          */
 /*                                                                     */
 /***********************************************************************/
 

diff --git a/otherlibs/labltk/support/fileevent.ml b/otherlibs/labltk/support/fileevent.ml
index 846a7519b8fe6557216c7409f9272823873866b6..ae1cc261a339a3ad4d32480d448c16208a66f59b 100644 (file)
--- a/otherlibs/labltk/support/fileevent.ml
+++ b/otherlibs/labltk/support/fileevent.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/fileevent.mli b/otherlibs/labltk/support/fileevent.mli
index 34760f0c7e3502017db717a82d7fd781b594ccd1..f5468ca599c524d9ac3903bc8b1d39d5364612c5 100644 (file)
--- a/otherlibs/labltk/support/fileevent.mli
+++ b/otherlibs/labltk/support/fileevent.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml
index 26b97c0bda9c5c2e837749b06abb3f405e876a38..28cb4737d9f73670974e8949991c9375b4c1d7e4 100644 (file)
--- a/otherlibs/labltk/support/protocol.ml
+++ b/otherlibs/labltk/support/protocol.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli
index 9b5ae39362562510b810df44c557072dc7131a84..1ce6718a854c30514fc63b4a599a196699707be9 100644 (file)
--- a/otherlibs/labltk/support/protocol.mli
+++ b/otherlibs/labltk/support/protocol.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/rawwidget.ml b/otherlibs/labltk/support/rawwidget.ml
index 99b1dce1a91a854fbee2920399c109527e76def7..f216df726a5a1e999dd1c78f5fdb343cdb8934ec 100644 (file)
--- a/otherlibs/labltk/support/rawwidget.ml
+++ b/otherlibs/labltk/support/rawwidget.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/rawwidget.mli b/otherlibs/labltk/support/rawwidget.mli
index 4eda7311c70596a288965f76a9cc9f2cd7a665cd..e9f82ef2cc1c18bbf25d683ec7cde9633b67a660 100644 (file)
--- a/otherlibs/labltk/support/rawwidget.mli
+++ b/otherlibs/labltk/support/rawwidget.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/slave.ml b/otherlibs/labltk/support/slave.ml
index 51eae853bbe3926fa5cf6ef0dcf6bd637d5eaf02..44349c05cfa4c5db9a4a07fc02da1fd5a46e2e0f 100644 (file)
--- a/otherlibs/labltk/support/slave.ml
+++ b/otherlibs/labltk/support/slave.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/support.ml b/otherlibs/labltk/support/support.ml
index fa650e8a9ec33484b21dbca1587e3e97b4acf75d..7d019967c02fd2ac4e911c66aec1e56e491c58b5 100644 (file)
--- a/otherlibs/labltk/support/support.ml
+++ b/otherlibs/labltk/support/support.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/support.mli b/otherlibs/labltk/support/support.mli
index 95a2255cb5666f2118782b26f1826ff2c26ccf7f..fe30208ac20baad0c725f9ab4356dd13d4ed8221 100644 (file)
--- a/otherlibs/labltk/support/support.mli
+++ b/otherlibs/labltk/support/support.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/textvariable.ml b/otherlibs/labltk/support/textvariable.ml
index ad9033d450b78881f60a152316a2504950131ecd..4e17a008adc6b2836d6d3aca75930882a322e470 100644 (file)
--- a/otherlibs/labltk/support/textvariable.ml
+++ b/otherlibs/labltk/support/textvariable.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/textvariable.mli b/otherlibs/labltk/support/textvariable.mli
index dfa511a29f5b7be8c54fa3d092af13a1210319f3..f18f6cc86c958df0938baaa7eb514f400f2c6eca 100644 (file)
--- a/otherlibs/labltk/support/textvariable.mli
+++ b/otherlibs/labltk/support/textvariable.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml
index a6ef8c29922f6b325d1ba7c51453683e80b26d9b..d5bd176aa79166297ccde3732fe31174e3271cea 100644 (file)
--- a/otherlibs/labltk/support/timer.ml
+++ b/otherlibs/labltk/support/timer.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/timer.mli b/otherlibs/labltk/support/timer.mli
index a45e1c9d22392f0d0bf991748b11a43e4f94830f..4b31668c9cd5928a2beb4f7c61b9eb20c8644dec 100644 (file)
--- a/otherlibs/labltk/support/timer.mli
+++ b/otherlibs/labltk/support/timer.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/tkthread.ml b/otherlibs/labltk/support/tkthread.ml
index ecdf61460a697aaec865cb3c45094b9d88955da0..4ae36685c9676661f72c197a687af4045856b84a 100644 (file)
--- a/otherlibs/labltk/support/tkthread.ml
+++ b/otherlibs/labltk/support/tkthread.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*              LablTk, Tcl/Tk interface of Objective Caml             *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*         Jacques Garrigue, Nagoya University Mathematics Dept.       *)
 (*                                                                     *)
@@ -8,7 +8,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/tkthread.mli b/otherlibs/labltk/support/tkthread.mli
index 4f20e6140bdf96bbba1713684b2620d355f15e47..2bc104da2ef9d32820bc00dfe85cdcca501c2933 100644 (file)
--- a/otherlibs/labltk/support/tkthread.mli
+++ b/otherlibs/labltk/support/tkthread.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*              LablTk, Tcl/Tk interface of Objective Caml             *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*         Jacques Garrigue, Nagoya University Mathematics Dept.       *)
 (*                                                                     *)
@@ -8,7 +8,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml
index 97a0b0eb84a33d3ab04ee75c71287fc270b43dd9..34f6908deb9460cca87e29427667591c8228f44b 100644 (file)
--- a/otherlibs/labltk/support/tkwait.ml
+++ b/otherlibs/labltk/support/tkwait.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/widget.ml b/otherlibs/labltk/support/widget.ml
index 65e0d26a9edffd70f32521eba6a36497a13f0920..083e4b96c33852765058da2ef750c4b8b9d9c91a 100644 (file)
--- a/otherlibs/labltk/support/widget.ml
+++ b/otherlibs/labltk/support/widget.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/labltk/support/widget.mli b/otherlibs/labltk/support/widget.mli
index f9c832783a6d5f32ef282a8a2e06e82eaed33bd5..7761f2f2c821eca266248d1c584ebb4cf0ac36e8 100644 (file)
--- a/otherlibs/labltk/support/widget.mli
+++ b/otherlibs/labltk/support/widget.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
+(*                 MLTk, Tcl/Tk interface of OCaml                     *)
 (*                                                                     *)
 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
 (*               projet Cristal, INRIA Rocquencourt                    *)
@@ -10,7 +10,7 @@
 (*  en Automatique and Kyoto University.  All rights reserved.         *)
 (*  This file is distributed under the terms of the GNU Library        *)
 (*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
+(*  described in file LICENSE found in the OCaml source tree.          *)
 (*                                                                     *)
 (***********************************************************************)
 

diff --git a/otherlibs/num/.cvsignore b/otherlibs/num/.cvsignore
deleted file mode 100644 (file)
index 02023cb..0000000
--- a/otherlibs/num/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-libnums.x
-*.c.x
-so_locations
-*.so
-*.a

diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend
index 1e783ec0f9a60984efb905860596a84d316869c2..2013ac35b837e99981ceb6113bcf54d5246e2701 100644 (file)
--- a/otherlibs/num/.depend
+++ b/otherlibs/num/.depend
@@ -1,11 +1,9 @@
 bng.o: bng.c bng.h ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/compatibility.h bng_amd64.c \
   bng_digit.c
-bng_alpha.o: bng_alpha.c
 bng_amd64.o: bng_amd64.c
 bng_digit.o: bng_digit.c
 bng_ia32.o: bng_ia32.c
-bng_mips.o: bng_mips.c
 bng_ppc.o: bng_ppc.c
 bng_sparc.o: bng_sparc.c
 nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \
@@ -13,28 +11,28 @@ nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \
   ../../byterun/config.h ../../byterun/../config/m.h \
   ../../byterun/../config/s.h ../../byterun/mlvalues.h \
   ../../byterun/config.h ../../byterun/custom.h ../../byterun/intext.h \
-  ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \
+  ../../byterun/io.h ../../byterun/fail.h ../../byterun/hash.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h \
   ../../byterun/mlvalues.h bng.h nat.h
-arith_flags.cmi:
-arith_status.cmi:
-big_int.cmi: nat.cmi
-int_misc.cmi:
-nat.cmi:
-num.cmi: ratio.cmi nat.cmi big_int.cmi
-ratio.cmi: nat.cmi big_int.cmi
-arith_flags.cmo: arith_flags.cmi
-arith_flags.cmx: arith_flags.cmi
-arith_status.cmo: arith_flags.cmi arith_status.cmi
-arith_status.cmx: arith_flags.cmx arith_status.cmi
-big_int.cmo: nat.cmi int_misc.cmi big_int.cmi
-big_int.cmx: nat.cmx int_misc.cmx big_int.cmi
-int_misc.cmo: int_misc.cmi
-int_misc.cmx: int_misc.cmi
-nat.cmo: int_misc.cmi nat.cmi
-nat.cmx: int_misc.cmx nat.cmi
-num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
-num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
-ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
-ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi
+arith_flags.cmi :
+arith_status.cmi :
+big_int.cmi : nat.cmi
+int_misc.cmi :
+nat.cmi :
+num.cmi : ratio.cmi nat.cmi big_int.cmi
+ratio.cmi : nat.cmi big_int.cmi
+arith_flags.cmo : arith_flags.cmi
+arith_flags.cmx : arith_flags.cmi
+arith_status.cmo : arith_flags.cmi arith_status.cmi
+arith_status.cmx : arith_flags.cmx arith_status.cmi
+big_int.cmo : nat.cmi int_misc.cmi big_int.cmi
+big_int.cmx : nat.cmx int_misc.cmx big_int.cmi
+int_misc.cmo : int_misc.cmi
+int_misc.cmx : int_misc.cmi
+nat.cmo : int_misc.cmi nat.cmi
+nat.cmx : int_misc.cmx nat.cmi
+num.cmo : ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi
+num.cmx : ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi
+ratio.cmo : nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi
+ratio.cmx : nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi

diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile
index 0a4349e8026f7ff2d3e5ed02236b137e02c373f1..e5bcb97cadb9aff9d76d6ae5f362ba56fbfcbe0d 100644 (file)
--- a/otherlibs/num/Makefile
+++ b/otherlibs/num/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -28,7 +28,7 @@ clean::
        rm -f *~
 
 bng.$(O): bng.h bng_digit.c \
-       bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
+       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
 
 depend:
        gcc -MM $(CFLAGS) *.c > .depend

diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
index 16103b2b009587b940b80180bdb9ed675b8806df..4ac69c7cad40db81d384fcf3b3b672a2f8769a3c 100644 (file)
--- a/otherlibs/num/Makefile.nt
+++ b/otherlibs/num/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -28,7 +28,7 @@ clean::
        rm -f *~
 
 bng.$(O): bng.h bng_digit.c \
-       bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
+       bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
 
 depend:
        sed -e 's/\.o/.$(O)/g' .depend > .depend.nt

diff --git a/otherlibs/num/arith_flags.ml b/otherlibs/num/arith_flags.ml
index 00e2813e620153d59d9d1707ebac6ae2ff90f9a2..048d4f8dba713af9f2bb1607e3d22919ad5f6d42 100644 (file)
--- a/otherlibs/num/arith_flags.ml
+++ b/otherlibs/num/arith_flags.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/arith_flags.mli b/otherlibs/num/arith_flags.mli
index 36160edb24de812491c3ca211f975457c4442081..6539424311e04714f5660fd623825e7ea998ce56 100644 (file)
--- a/otherlibs/num/arith_flags.mli
+++ b/otherlibs/num/arith_flags.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/arith_status.ml b/otherlibs/num/arith_status.ml
index 8b6fa9f72770e09c8f422cdb659940ca6fb04867..0f9deb363b145ae62e36076811b6c5f1d611caa4 100644 (file)
--- a/otherlibs/num/arith_status.ml
+++ b/otherlibs/num/arith_status.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/arith_status.mli b/otherlibs/num/arith_status.mli
index 121b4d57568dcc45e9e2ad62630d51ad10f717c6..170e8cd4c2bc566ae3a91baea16756fadf8d6d77 100644 (file)
--- a/otherlibs/num/arith_status.mli
+++ b/otherlibs/num/arith_status.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml
index b96b8e1f426516d5c7a74645062b98e6bee79406..34de4b1272ef5d083ad3bc17752616abb3bca3bc 100644 (file)
--- a/otherlibs/num/big_int.ml
+++ b/otherlibs/num/big_int.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli
index 2ac7b7eb6f2e665ae52644c669fba4f774da432e..46621f9414e81f2eea13266b62138ae7646b025b 100644 (file)
--- a/otherlibs/num/big_int.mli
+++ b/otherlibs/num/big_int.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/bignum/.cvsignore b/otherlibs/num/bignum/.cvsignore
deleted file mode 100644 (file)
index c76baff..0000000
--- a/otherlibs/num/bignum/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-libbignum.x

diff --git a/otherlibs/num/bng.c b/otherlibs/num/bng.c
index 74502470090633411faba7170d885be060362cd7..5bbedb0b465c05278cf25d34b275d3b7759152b6 100644 (file)
--- a/otherlibs/num/bng.c
+++ b/otherlibs/num/bng.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/num/bng.h b/otherlibs/num/bng.h
index 6d12c87cb3c6fe9e37fc5c0ccf9ecf31d3175f27..19f2e2b9cf0997e2222c57f88c28e3af3fb4b93c 100644 (file)
--- a/otherlibs/num/bng.h
+++ b/otherlibs/num/bng.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/num/bng_alpha.c b/otherlibs/num/bng_alpha.c
deleted file mode 100644 (file)
index 5bf964b..0000000
--- a/otherlibs/num/bng_alpha.c
+++ /dev/null
@@ -1,22 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 2003 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../../LICENSE.  */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the Alpha architecture. */
-
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("mulq %2, %3, %0 \n\t"                                                \
-      "umulh %2, %3, %1"                                                    \
-      : "=&r" (resl), "=r" (resh)                                           \
-      : "r" (arg1), "r" (arg2))

diff --git a/otherlibs/num/bng_amd64.c b/otherlibs/num/bng_amd64.c
index e829eef23ee59270dc0a5b386b953f87e704fc5b..ecf9f2535dbc22cb4937d9cea1a47fce5c877870 100644 (file)
--- a/otherlibs/num/bng_amd64.c
+++ b/otherlibs/num/bng_amd64.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/num/bng_digit.c b/otherlibs/num/bng_digit.c
index 168b44ad3dfa710bed4b5af552c6e3a120dc09d1..e429197c223228c0d1f5e7670e6c2ca5c51dbef3 100644 (file)
--- a/otherlibs/num/bng_digit.c
+++ b/otherlibs/num/bng_digit.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/num/bng_ia32.c b/otherlibs/num/bng_ia32.c
index bbca8e9dcd1e2052df460106d7c85de310600d2c..b4981cd48851935d5dd26fd28a4273801669b719 100644 (file)
--- a/otherlibs/num/bng_ia32.c
+++ b/otherlibs/num/bng_ia32.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/num/bng_mips.c b/otherlibs/num/bng_mips.c
deleted file mode 100644 (file)
index f246843..0000000
--- a/otherlibs/num/bng_mips.c
+++ /dev/null
@@ -1,23 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
-/*                                                                     */
-/*  Copyright 2003 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../../LICENSE.  */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/* Code specific to the MIPS architecture. */
-
-#define BngMult(resh,resl,arg1,arg2)                                        \
-  asm("multu %2, %3 \n\t"                                                   \
-      "mflo %0 \n\t"                                                        \
-      "mfhi %1"                                                             \
-      : "=r" (resl), "=r" (resh)                                            \
-      : "r" (arg1), "r" (arg2))

diff --git a/otherlibs/num/bng_ppc.c b/otherlibs/num/bng_ppc.c
index 32d573cd0f357dbb48219794b910879ece950e50..6bbf108e9c8d61f91a06ac026a8a24b689d55f4c 100644 (file)
--- a/otherlibs/num/bng_ppc.c
+++ b/otherlibs/num/bng_ppc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -91,4 +91,4 @@
       "mulhwu %1, %2, %3"                                                   \
       : "=&r" (resl), "=r" (resh)                                           \
       : "r" (arg1), "r" (arg2))
-#endif
\ No newline at end of file
+#endif

diff --git a/otherlibs/num/bng_sparc.c b/otherlibs/num/bng_sparc.c
index 934c0b2f7e5a2cd52f136e049a2ca65b413aa4ee..4e46a316ae710afab80af8cb2ed34fcc68dd0fc3 100644 (file)
--- a/otherlibs/num/bng_sparc.c
+++ b/otherlibs/num/bng_sparc.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/num/int_misc.ml b/otherlibs/num/int_misc.ml
index b7eb4c67d40053c9cb17e0db1416af9bd57a2c07..99713b916e804ddff212b167df25b53bc826cc48 100644 (file)
--- a/otherlibs/num/int_misc.ml
+++ b/otherlibs/num/int_misc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/int_misc.mli b/otherlibs/num/int_misc.mli
index 28bb335b8ec848e14497e6ef78a22661246dcd94..7f465c5ad718e785e9788dfdc48b32c6de5597a7 100644 (file)
--- a/otherlibs/num/int_misc.mli
+++ b/otherlibs/num/int_misc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/nat.h b/otherlibs/num/nat.h
index 7f67b916a1396c936c9347fe9998c4c69242626b..62c7ac9885a83df350d252016c31a6cc346daff3 100644 (file)
--- a/otherlibs/num/nat.h
+++ b/otherlibs/num/nat.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml
index cda80d5d48e995659bbf9843abe598c8b5e87434..44742a213bec0a91d29c6cdda82940d4826f86eb 100644 (file)
--- a/otherlibs/num/nat.ml
+++ b/otherlibs/num/nat.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli
index 3b32ac8dcf8a340820983759f8800a2a5773a88e..39f1c5908c1c0c1cb3de743e9f9e107ede1259b2 100644 (file)
--- a/otherlibs/num/nat.mli
+++ b/otherlibs/num/nat.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
index cffe1237411e92343993af0cec16bc3202d8f85d..521585165991ace632a202fd4e41bad81b1736f6 100644 (file)
--- a/otherlibs/num/nat_stubs.c
+++ b/otherlibs/num/nat_stubs.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -18,6 +18,7 @@
 #include "custom.h"
 #include "intext.h"
 #include "fail.h"
+#include "hash.h"
 #include "memory.h"
 #include "mlvalues.h"
 
@@ -26,6 +27,7 @@
 
 /* Stub code for the Nat module. */
 
+static intnat hash_nat(value);
 static void serialize_nat(value, uintnat *, uintnat *);
 static uintnat deserialize_nat(void * dst);
 
@@ -33,9 +35,10 @@ static struct custom_operations nat_operations = {
   "_nat",
   custom_finalize_default,
   custom_compare_default,
-  custom_hash_default,
+  hash_nat,
   serialize_nat,
-  deserialize_nat
+  deserialize_nat,
+  custom_compare_ext_default
 };
 
 CAMLprim value initialize_nat(value unit)
@@ -389,3 +392,28 @@ static uintnat deserialize_nat(void * dst)
 #endif
   return len * 4;
 }
+
+static intnat hash_nat(value v)
+{
+  bngsize len, i;
+  uint32 h;
+
+  len = bng_num_digits(&Digit_val(v,0), Wosize_val(v) - 1);
+  h = 0;
+  for (i = 0; i < len; i++) {
+    bngdigit d = Digit_val(v, i);
+#ifdef ARCH_SIXTYFOUR
+    /* Mix the two 32-bit halves as if we were on a 32-bit platform,
+       namely low 32 bits first, then high 32 bits.
+       Also, ignore final 32 bits if they are zero. */
+    h = caml_hash_mix_uint32(h, (uint32) d);
+    d = d >> 32;
+    if (d == 0 && i + 1 == len) break;
+    h = caml_hash_mix_uint32(h, (uint32) d);
+#else
+    h = caml_hash_mix_uint32(h, d);
+#endif
+  }
+  return h;
+}
+

diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml
index 52fe8cc0e8570ef7f00e7d8f120cde86b339e974..4ede5ee49cda9069ae205e56b90069ca399c6e7b 100644 (file)
--- a/otherlibs/num/num.ml
+++ b/otherlibs/num/num.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli
index 8bf3d4e6e727ab62d7303910fe4a817252bf784e..17733384703b17865a63700a4db0881c78ae0114 100644 (file)
--- a/otherlibs/num/num.mli
+++ b/otherlibs/num/num.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
@@ -155,7 +155,9 @@ val approx_num_exp : int -> num -> string
    first argument is the number of digits in the mantissa. *)
 
 val num_of_string : string -> num
-(** Convert a string to a number. *)
+(** Convert a string to a number.
+   Raise [Failure "num_of_string"] if the given string is not
+   a valid representation of an integer *)
 
 (** {6 Coercions between numerical types} *)
 

diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml
index 7885df15d6073b0e7e32f4b1c5272f09b5ee610b..fe0170f299405093cbe1126982940432b75e389e 100644 (file)
--- a/otherlibs/num/ratio.ml
+++ b/otherlibs/num/ratio.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/otherlibs/num/ratio.mli b/otherlibs/num/ratio.mli
index 12621f08a260c64b50165a507ec2e441f3a80562..408aea9b48d991aceac556ef9c01c649139ec478 100644 (file)
--- a/otherlibs/num/ratio.mli
+++ b/otherlibs/num/ratio.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*    Valerie Menissier-Morain, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
@@ -13,7 +13,10 @@
 
 (* $Id$ *)
 
-(* Module [Ratio]: operations on rational numbers *)
+(** Operation on rational numbers.
+
+    This module is used to support the implementation of {!Num} and
+    should not be called directly. *)
 
 open Nat
 open Big_int
@@ -25,6 +28,8 @@ open Big_int
 
 type ratio
 
+(**/**)
+
 val null_denominator : ratio -> bool
 val numerator_ratio : ratio -> big_int
 val denominator_ratio : ratio -> big_int
@@ -32,8 +37,9 @@ val sign_ratio : ratio -> int
 val normalize_ratio : ratio -> ratio
 val cautious_normalize_ratio : ratio -> ratio
 val cautious_normalize_ratio_when_printing : ratio -> ratio
-val create_ratio : big_int -> big_int -> ratio
+val create_ratio : big_int -> big_int -> ratio (* assumes nothing *)
 val create_normalized_ratio : big_int -> big_int -> ratio
+                              (* assumes normalized argument *)
 val is_normalized_ratio : ratio -> bool
 val report_sign_ratio : ratio -> big_int -> big_int
 val abs_ratio : ratio -> ratio

diff --git a/otherlibs/str/.cvsignore b/otherlibs/str/.cvsignore
deleted file mode 100644 (file)
index 49c78e5..0000000
--- a/otherlibs/str/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-libstr.x
-*.c.x
-so_locations
-*.so
-*.a

diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend
index df6eb9af0898aff33da1e06ecc06255e5789eb26..5be8377c2d0debc2916a90c3f3e11c7902959bcf 100644 (file)
--- a/otherlibs/str/.depend
+++ b/otherlibs/str/.depend
@@ -4,6 +4,6 @@ strstubs.o: strstubs.c ../../byterun/mlvalues.h \
   ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \
   ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h
-str.cmi:
-str.cmo: str.cmi
-str.cmx: str.cmi
+str.cmi :
+str.cmo : str.cmi
+str.cmx : str.cmi

diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile
index b6c16a07691823493f87c8de2825fa189083edd2..e36000e4acf8222ab00c81381ceab400cec3fbcb 100644 (file)
--- a/otherlibs/str/Makefile
+++ b/otherlibs/str/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt
index 5aeff80b25c8c08ff9a02bb94fe4b50abc6d8e04..b0420b39b87607230d98de3eec3259fa29c5db42 100644 (file)
--- a/otherlibs/str/Makefile.nt
+++ b/otherlibs/str/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml
index f3f760acb93af36a90f7d6762052687cb3f9a5b8..5d53168fd84666165a2ea9331cbe650bd6bb5125 100644 (file)
--- a/otherlibs/str/str.ml
+++ b/otherlibs/str/str.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli
index b63faf845aee799047812757974128be820701c5..a4d65b6aed40c377c6b52b3282d163e4048b1c3e 100644 (file)
--- a/otherlibs/str/str.mli
+++ b/otherlibs/str/str.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/str/strstubs.c b/otherlibs/str/strstubs.c
index b8d53ff8faa16a4c3744c34ccb63b3f6b3e5405e..fc2f46f8e829ba7996fb3636652fee3148a8e047 100644 (file)
--- a/otherlibs/str/strstubs.c
+++ b/otherlibs/str/strstubs.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt          */
 /*                                                                     */

diff --git a/otherlibs/systhreads/.cvsignore b/otherlibs/systhreads/.cvsignore
deleted file mode 100644 (file)
index 1f1e6a3..0000000
--- a/otherlibs/systhreads/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-*.x
-thread.ml
-so_locations
-*.so
-*.a

diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend
index 9c6889b708342a668b0a6766b134abdbcc919374..85add2e5928e330f5fc6615b8733df54a67e4740 100644 (file)
--- a/otherlibs/systhreads/.depend
+++ b/otherlibs/systhreads/.depend
@@ -9,18 +9,18 @@ st_stubs.o: st_stubs.c ../../byterun/alloc.h \
   ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \
   ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \
   ../../byterun/sys.h threads.h st_posix.h
-condition.cmi: mutex.cmi
-event.cmi:
-mutex.cmi:
-thread.cmi:
-threadUnix.cmi:
-condition.cmo: mutex.cmi condition.cmi
-condition.cmx: mutex.cmx condition.cmi
-event.cmo: mutex.cmi condition.cmi event.cmi
-event.cmx: mutex.cmx condition.cmx event.cmi
-mutex.cmo: mutex.cmi
-mutex.cmx: mutex.cmi
-thread.cmo: thread.cmi
-thread.cmx: thread.cmi
-threadUnix.cmo: thread.cmi threadUnix.cmi
-threadUnix.cmx: thread.cmx threadUnix.cmi
+condition.cmi : mutex.cmi
+event.cmi :
+mutex.cmi :
+thread.cmi :
+threadUnix.cmi :
+condition.cmo : mutex.cmi condition.cmi
+condition.cmx : mutex.cmx condition.cmi
+event.cmo : mutex.cmi condition.cmi event.cmi
+event.cmx : mutex.cmx condition.cmx event.cmi
+mutex.cmo : mutex.cmi
+mutex.cmx : mutex.cmi
+thread.cmo : thread.cmi
+thread.cmx : thread.cmi
+threadUnix.cmo : thread.cmi threadUnix.cmi
+threadUnix.cmx : thread.cmx threadUnix.cmi

diff --git a/otherlibs/systhreads/.ignore b/otherlibs/systhreads/.ignore
new file mode 100644 (file)
index 0000000..71702b8
--- /dev/null
+++ b/otherlibs/systhreads/.ignore
@@ -0,0 +1 @@
+thread.ml

diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile
index f5c80c0e2dbf98eb27f85a769a1402bdadfbad5e..fbdd899466e9979314a91b1c94edb238615fac40 100644 (file)
--- a/otherlibs/systhreads/Makefile
+++ b/otherlibs/systhreads/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt
index 8c559e0b6d78850a10bfcb1740f50db5152af07a..8cc9dd2649cb5a33c895836d7a8387ee3605516a 100644 (file)
--- a/otherlibs/systhreads/Makefile.nt
+++ b/otherlibs/systhreads/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/systhreads/condition.ml b/otherlibs/systhreads/condition.ml
index 6549c642d81d64e57293f0fd218a82974b11b052..6bdac6a3697ed25ab46134370f20cfdf4daffd13 100644 (file)
--- a/otherlibs/systhreads/condition.ml
+++ b/otherlibs/systhreads/condition.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                         Caml Special Light                          *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/condition.mli b/otherlibs/systhreads/condition.mli
index 5bc9d6740af198576161157f713f1d02171e1014..d13b30d866a65f0d96baf5e40c49f9c13ec20f22 100644 (file)
--- a/otherlibs/systhreads/condition.mli
+++ b/otherlibs/systhreads/condition.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/event.ml b/otherlibs/systhreads/event.ml
index 74f457b06d416de442e28184001f4ec99ab79c57..ff137e981d0adcacf49014909dbc303e514b2ed0 100644 (file)
--- a/otherlibs/systhreads/event.ml
+++ b/otherlibs/systhreads/event.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli
index 08d6b0bf6b54299296134bbba9454cd3ad65c331..11842e5ad038da93ac88c95a1cb28b8b172c347b 100644 (file)
--- a/otherlibs/systhreads/event.mli
+++ b/otherlibs/systhreads/event.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/mutex.ml b/otherlibs/systhreads/mutex.ml
index 4e108f4a9f03b502791cea5a49eaf30147379e73..5e9cc886c555a82cb51e625102c898f9f7ca7561 100644 (file)
--- a/otherlibs/systhreads/mutex.ml
+++ b/otherlibs/systhreads/mutex.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                         Caml Special Light                          *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt           *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/mutex.mli b/otherlibs/systhreads/mutex.mli
index b1fe14135862e15793677e43c29bb6100df76303..844d4e5d4c27e5b7ef2db686c1cd03602478d052 100644 (file)
--- a/otherlibs/systhreads/mutex.mli
+++ b/otherlibs/systhreads/mutex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/st_posix.h b/otherlibs/systhreads/st_posix.h
index 708a4abfed1bde6644c46cc3b208b62a64544c02..070a4496fea887411fc26498a9acc77859d85a9e 100644 (file)
--- a/otherlibs/systhreads/st_posix.h
+++ b/otherlibs/systhreads/st_posix.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                             Objective Caml                          */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -254,7 +254,7 @@ static int st_event_create(st_event * res)
   rc = pthread_mutex_init(&e->lock, NULL);
   if (rc != 0) { free(e); return rc; }
   rc = pthread_cond_init(&e->triggered, NULL);
-  if (rc != 0) { free(e); return rc; }
+  if (rc != 0) { pthread_mutex_destroy(&e->lock); free(e); return rc; }
   e->status = 0;
   *res = e;
   return 0;
@@ -320,11 +320,8 @@ static void * caml_thread_tick(void * arg)
 {
   struct timeval timeout;
   sigset_t mask;
-#ifdef __linux__
-  int tickcount = 0;
-#endif
 
-  /* Block all signals so that we don't try to execute a Caml signal handler */
+  /* Block all signals so that we don't try to execute an OCaml signal handler*/
   sigfillset(&mask);
   pthread_sigmask(SIG_BLOCK, &mask, NULL);
   /* Allow async cancellation */
@@ -339,18 +336,6 @@ static void * caml_thread_tick(void * arg)
      go through caml_handle_signal(), just record signal delivery via
      caml_record_signal(). */
     caml_record_signal(SIGPREEMPTION);
-#ifdef __linux__
-    /* Hack around LinuxThreads' non-standard signal handling:
-       if program is killed on a signal, e.g. SIGINT, the current
-       thread will not die on this signal (because of the signal blocking
-       above).  Hence, periodically check that the thread manager (our
-       parent process) still exists. */
-    tickcount++;
-    if (tickcount >= 2000 / Thread_timeout) { /* every 2 secs approx */
-      tickcount = 0;
-      if (getppid() == 1) pthread_exit(NULL);
-    }
-#endif
   }
   return NULL;                  /* prevents compiler warning */
 }

diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c
index 55e35d4190e2cea5814a96b01915179eb8f63d41..9b2493a16e838ec757c6428b5eab80a8c4d2f725 100644 (file)
--- a/otherlibs/systhreads/st_stubs.c
+++ b/otherlibs/systhreads/st_stubs.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                             Objective Caml                          */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -94,7 +94,7 @@ static caml_thread_t all_threads = NULL;
 /* The descriptor for the currently executing thread */
 static caml_thread_t curr_thread = NULL;
 
-/* The master lock protecting the Caml runtime system */
+/* The master lock protecting the OCaml runtime system */
 static st_masterlock caml_master_lock;
 
 /* Whether the ``tick'' thread is already running */
@@ -344,7 +344,10 @@ static value caml_thread_new_descriptor(value clos)
 
 static void caml_thread_remove_info(caml_thread_t th)
 {
-  if (th->next == th) all_threads = NULL; /* last Caml thread exiting */
+  if (th->next == th)
+    all_threads = NULL; /* last OCaml thread exiting */
+  else if (all_threads == th)
+    all_threads = th->next;     /* PR#5295 */
   th->next->prev = th->prev;
   th->prev->next = th->next;
 #ifndef NATIVE_CODE
@@ -646,7 +649,7 @@ CAMLprim value caml_thread_exit(value unit)   /* ML */
 #endif
   caml_thread_stop();
   if (exit_buf != NULL) {
-    /* Native-code and (main thread or thread created by Caml) */
+    /* Native-code and (main thread or thread created by OCaml) */
     siglongjmp(exit_buf->buf, 1);
   } else {
     /* Bytecode, or thread created from C */
@@ -685,18 +688,23 @@ static void caml_mutex_finalize(value wrapper)
   st_mutex_destroy(Mutex_val(wrapper));
 }
 
-static int caml_mutex_condition_compare(value wrapper1, value wrapper2)
+static int caml_mutex_compare(value wrapper1, value wrapper2)
 {
   st_mutex mut1 = Mutex_val(wrapper1);
   st_mutex mut2 = Mutex_val(wrapper2);
   return mut1 == mut2 ? 0 : mut1 < mut2 ? -1 : 1;
 }
 
+static intnat caml_mutex_hash(value wrapper)
+{
+  return (intnat) (Mutex_val(wrapper));
+}
+
 static struct custom_operations caml_mutex_ops = {
   "_mutex",
   caml_mutex_finalize,
-  caml_mutex_condition_compare,
-  custom_hash_default,
+  caml_mutex_compare,
+  caml_mutex_hash,
   custom_serialize_default,
   custom_deserialize_default
 };
@@ -759,13 +767,26 @@ static void caml_condition_finalize(value wrapper)
   st_condvar_destroy(Condition_val(wrapper));
 }
 
+static int caml_condition_compare(value wrapper1, value wrapper2)
+{
+  st_condvar cond1 = Condition_val(wrapper1);
+  st_condvar cond2 = Condition_val(wrapper2);
+  return cond1 == cond2 ? 0 : cond1 < cond2 ? -1 : 1;
+}
+
+static intnat caml_condition_hash(value wrapper)
+{
+  return (intnat) (Condition_val(wrapper));
+}
+
 static struct custom_operations caml_condition_ops = {
   "_condition",
   caml_condition_finalize,
-  caml_mutex_condition_compare,
-  custom_hash_default,
+  caml_condition_compare,
+  caml_condition_hash,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 CAMLprim value caml_condition_new(value unit)        /* ML */
@@ -818,13 +839,21 @@ static void caml_threadstatus_finalize(value wrapper)
   st_event_destroy(Threadstatus_val(wrapper));
 }
 
+static int caml_threadstatus_compare(value wrapper1, value wrapper2)
+{
+  st_event ts1 = Threadstatus_val(wrapper1);
+  st_event ts2 = Threadstatus_val(wrapper2);
+  return ts1 == ts2 ? 0 : ts1 < ts2 ? -1 : 1;
+}
+
 static struct custom_operations caml_threadstatus_ops = {
   "_threadstatus",
   caml_threadstatus_finalize,
-  custom_compare_default,
+  caml_threadstatus_compare,
   custom_hash_default,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 static value caml_threadstatus_new (void)

diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h
index d4ad98c00df422224d56fd2581aab268a136b9fd..da602b7f8b74cff22a8e54bfc792e86e96753e4d 100644 (file)
--- a/otherlibs/systhreads/st_win32.h
+++ b/otherlibs/systhreads/st_win32.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                             Objective Caml                          */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -15,6 +15,7 @@
 
 /* Win32 implementation of the "st" interface */
 
+#define _WIN32_WINNT 0x0400
 #include <windows.h>
 #include <WinError.h>
 #include <stdio.h>

diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml
index b0f01dad5cd65e78aa92b94af05e248d62679782..ee01c9558b1b612f37358360202d3cf58daf7423 100644 (file)
--- a/otherlibs/systhreads/thread.ml
+++ b/otherlibs/systhreads/thread.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                         Objective Caml                              *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -63,7 +63,7 @@ let _ =
   at_exit
     (fun () ->
         thread_cleanup();
-        (* In case of DLL-embedded Ocaml the preempt_signal handler
+        (* In case of DLL-embedded OCaml the preempt_signal handler
            will point to nowhere after DLL unloading and an accidental
            preempt_signal will crash the main program. So restore the
            default handler. *)

diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli
index 3c2fc01b53aa2ce24fa5e37a4fb8c17cf8533d10..42d18e63557f07f1ecd61c1209b955e538ffe764 100644 (file)
--- a/otherlibs/systhreads/thread.mli
+++ b/otherlibs/systhreads/thread.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                         Objective Caml                              *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/threadUnix.ml b/otherlibs/systhreads/threadUnix.ml
index 71855ec6966aff5796c7bd2903aaf2a40a257470..d4b6fd59f5cde152038765072cdf8d28d9963e24 100644 (file)
--- a/otherlibs/systhreads/threadUnix.ml
+++ b/otherlibs/systhreads/threadUnix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/threadUnix.mli b/otherlibs/systhreads/threadUnix.mli
index c05346fef37ee3f0a55419df758d8576b3d2e7f4..9c7e76e56bf61d6e59d1be99f4e206b81036e1a9 100644 (file)
--- a/otherlibs/systhreads/threadUnix.mli
+++ b/otherlibs/systhreads/threadUnix.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/systhreads/threads.h b/otherlibs/systhreads/threads.h
index 3675e69fd1f4d741d1f79789c8dc18ac23e6e3f8..ff140cd5b3f1722e4de06bb74621d906efb05f87 100644 (file)
--- a/otherlibs/systhreads/threads.h
+++ b/otherlibs/systhreads/threads.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                             Objective Caml                          */
+/*                                OCaml                                */
 /*                                                                     */
 /*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         */
 /*                                                                     */
@@ -21,22 +21,22 @@ CAMLextern void caml_leave_blocking_section (void);
 #define caml_acquire_runtime_system caml_leave_blocking_section
 #define caml_release_runtime_system caml_enter_blocking_section
 
-/* Manage the master lock around the Caml run-time system.
-   Only one thread at a time can execute Caml compiled code or
-   Caml run-time system functions.
+/* Manage the master lock around the OCaml run-time system.
+   Only one thread at a time can execute OCaml compiled code or
+   OCaml run-time system functions.
 
-   When Caml calls a C function, the current thread holds the master
+   When OCaml calls a C function, the current thread holds the master
    lock.  The C function can release it by calling
-   [caml_release_runtime_system].  Then, another thread can execute Caml
-   code.  However, the calling thread must not access any Caml data,
-   nor call any runtime system function, nor call back into Caml.
+   [caml_release_runtime_system].  Then, another thread can execute OCaml
+   code.  However, the calling thread must not access any OCaml data,
+   nor call any runtime system function, nor call back into OCaml.
 
-   Before returning to its Caml caller, or accessing Caml data,
+   Before returning to its OCaml caller, or accessing OCaml data,
    or call runtime system functions, the current thread must
    re-acquire the master lock by calling [caml_acquire_runtime_system].
 
-   Symmetrically, if a C function (not called from Caml) wishes to
-   call back into Caml code, it should invoke [caml_acquire_runtime_system]
+   Symmetrically, if a C function (not called from OCaml) wishes to
+   call back into OCaml code, it should invoke [caml_acquire_runtime_system]
    first, then do the callback, then invoke [caml_release_runtime_system].
 
    For historical reasons, alternate names can be used:
@@ -49,9 +49,9 @@ CAMLextern void caml_leave_blocking_section (void);
 CAMLextern int caml_c_thread_register(void);
 CAMLextern int caml_c_thread_unregister(void);
 
-/* If a thread is created by C code (instead of by Caml itself),
-   it must be registered with the Caml runtime system before
-   being able to call back into Caml code or use other runtime system
+/* If a thread is created by C code (instead of by OCaml itself),
+   it must be registered with the OCaml runtime system before
+   being able to call back into OCaml code or use other runtime system
    functions.  Just call [caml_c_thread_register] once.
    Before the thread finishes, it must call [caml_c_thread_unregister].
    Both functions return 1 on success, 0 on error.

diff --git a/otherlibs/threads/.cvsignore b/otherlibs/threads/.cvsignore
deleted file mode 100644 (file)
index c17596c..0000000
--- a/otherlibs/threads/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-marshal.mli
-pervasives.mli
-unix.mli
-*.so
-*.a

diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend
index 7ce4479a414e608c13e7f12c8763a474dec76bb1..bc03050be32c5f6d2af8315418113357b3542491 100644 (file)
--- a/otherlibs/threads/.depend
+++ b/otherlibs/threads/.depend
@@ -9,24 +9,27 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \
   ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \
   ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \
   ../../byterun/sys.h
-condition.cmi: mutex.cmi
-event.cmi:
-mutex.cmi:
-thread.cmi: unix.cmo
-threadUnix.cmi: unix.cmo
-condition.cmo: thread.cmi mutex.cmi condition.cmi
-condition.cmx: thread.cmx mutex.cmx condition.cmi
-event.cmo: mutex.cmi condition.cmi event.cmi
-event.cmx: mutex.cmx condition.cmx event.cmi
-marshal.cmo: pervasives.cmo
-marshal.cmx: pervasives.cmx
-mutex.cmo: thread.cmi mutex.cmi
-mutex.cmx: thread.cmx mutex.cmi
-pervasives.cmo: unix.cmo
-pervasives.cmx: unix.cmx
-thread.cmo: unix.cmo thread.cmi
-thread.cmx: unix.cmx thread.cmi
-threadUnix.cmo: unix.cmo thread.cmi threadUnix.cmi
-threadUnix.cmx: unix.cmx thread.cmx threadUnix.cmi
-unix.cmo:
-unix.cmx:
+condition.cmi : mutex.cmi
+event.cmi :
+marshal.cmi :
+mutex.cmi :
+pervasives.cmi :
+thread.cmi : unix.cmi
+threadUnix.cmi : unix.cmi
+unix.cmi :
+condition.cmo : thread.cmi mutex.cmi condition.cmi
+condition.cmx : thread.cmx mutex.cmx condition.cmi
+event.cmo : mutex.cmi condition.cmi event.cmi
+event.cmx : mutex.cmx condition.cmx event.cmi
+marshal.cmo : pervasives.cmi marshal.cmi
+marshal.cmx : pervasives.cmx marshal.cmi
+mutex.cmo : thread.cmi mutex.cmi
+mutex.cmx : thread.cmx mutex.cmi
+pervasives.cmo : unix.cmi pervasives.cmi
+pervasives.cmx : unix.cmx pervasives.cmi
+thread.cmo : unix.cmi thread.cmi
+thread.cmx : unix.cmx thread.cmi
+threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi
+threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi
+unix.cmo : unix.cmi
+unix.cmx : unix.cmi

diff --git a/otherlibs/threads/.ignore b/otherlibs/threads/.ignore
new file mode 100644 (file)
index 0000000..fb2df56
--- /dev/null
+++ b/otherlibs/threads/.ignore
@@ -0,0 +1,3 @@
+marshal.mli
+pervasives.mli
+unix.mli

diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile
index 0e6ef86ff0aff4c057393f49f281badfd6cdeda1..3354a275bd29776aeeae7539de6dee0dbfcf1911 100644 (file)
--- a/otherlibs/threads/Makefile
+++ b/otherlibs/threads/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/threads/condition.ml b/otherlibs/threads/condition.ml
index e012a86e35a75eb0fa303c683216d6e1649616bf..ee687a85b9c6dd1d6c514dba7f477d7c4052e84a 100644 (file)
--- a/otherlibs/threads/condition.ml
+++ b/otherlibs/threads/condition.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/condition.mli b/otherlibs/threads/condition.mli
index 5bc9d6740af198576161157f713f1d02171e1014..d13b30d866a65f0d96baf5e40c49f9c13ec20f22 100644 (file)
--- a/otherlibs/threads/condition.mli
+++ b/otherlibs/threads/condition.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml
index 74f457b06d416de442e28184001f4ec99ab79c57..ff137e981d0adcacf49014909dbc303e514b2ed0 100644 (file)
--- a/otherlibs/threads/event.ml
+++ b/otherlibs/threads/event.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)

diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli
index 08d6b0bf6b54299296134bbba9454cd3ad65c331..11842e5ad038da93ac88c95a1cb28b8b172c347b 100644 (file)
--- a/otherlibs/threads/event.mli
+++ b/otherlibs/threads/event.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  David Nowak and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)

diff --git a/otherlibs/threads/marshal.ml b/otherlibs/threads/marshal.ml
index d31a667df8c883526cff2f640bd3f3fd7e7210ca..6f2bcfed78dbc68e62528d838f3d7018c172dcf2 100644 (file)
--- a/otherlibs/threads/marshal.ml
+++ b/otherlibs/threads/marshal.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/mutex.ml b/otherlibs/threads/mutex.ml
index f0f6845b21a6e22967f15580ee586805dbb218fe..12e3f534dde80a363a2ed921c545e2f439fe62b6 100644 (file)
--- a/otherlibs/threads/mutex.ml
+++ b/otherlibs/threads/mutex.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/mutex.mli b/otherlibs/threads/mutex.mli
index b1fe14135862e15793677e43c29bb6100df76303..844d4e5d4c27e5b7ef2db686c1cd03602478d052 100644 (file)
--- a/otherlibs/threads/mutex.mli
+++ b/otherlibs/threads/mutex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy and Damien Doligez, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml
index 08115a2ff8870e7a5a545e1ca46d4e936bfe8b16..f83a1cf0dc8d4b56202eb6774d1011d4d47a7d80 100644 (file)
--- a/otherlibs/threads/pervasives.ml
+++ b/otherlibs/threads/pervasives.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -94,6 +94,7 @@ external acos : float -> float = "caml_acos_float" "acos" "float"
 external asin : float -> float = "caml_asin_float" "asin" "float"
 external atan : float -> float = "caml_atan_float" "atan" "float"
 external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
+external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" "float"
 external cos : float -> float = "caml_cos_float" "cos" "float"
 external cosh : float -> float = "caml_cosh_float" "cosh" "float"
 external log : float -> float = "caml_log_float" "log" "float"
@@ -107,6 +108,7 @@ external tanh : float -> float = "caml_tanh_float" "tanh" "float"
 external ceil : float -> float = "caml_ceil_float" "ceil" "float"
 external floor : float -> float = "caml_floor_float" "floor" "float"
 external abs_float : float -> float = "%absfloat"
+external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" "float"
 external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
 external frexp : float -> float * int = "caml_frexp_float"
 external ldexp : float -> int -> float = "caml_ldexp_float"

diff --git a/otherlibs/threads/scheduler.c b/otherlibs/threads/scheduler.c
index c73ac67e81a002a94dc99f3d53b7fe2efc16668f..3f51979032ae2ccb1c5e38053bf87b1534e2eefb 100644 (file)
--- a/otherlibs/threads/scheduler.c
+++ b/otherlibs/threads/scheduler.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml
index 723669a39d96e67a8cd4a55fd3b13f5175d733a6..f4bbd8a5ae40687947db6dd7013443d6f853d75a 100644 (file)
--- a/otherlibs/threads/thread.ml
+++ b/otherlibs/threads/thread.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli
index 9577a54eb0c625a3e8da94d2ccb0079a55f10e04..e97e55ab1530c9be0e3ea6639d4747787d1b5328 100644 (file)
--- a/otherlibs/threads/thread.mli
+++ b/otherlibs/threads/thread.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml
index 66a3704c198f9660bc22bbaf10d1729827dff172..bd4181b99689b61bf06cad16f7b03da4d74468a1 100644 (file)
--- a/otherlibs/threads/threadUnix.ml
+++ b/otherlibs/threads/threadUnix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli
index 1b4dde29b64c1e774050433a0341411678aacbca..22ed9330e89d0af9117df1caf40ba2100e69cbe0 100644 (file)
--- a/otherlibs/threads/threadUnix.mli
+++ b/otherlibs/threads/threadUnix.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml
index 5a8bb697da3734789854bbbbecc311d792b9d51d..609c098a3dc4da8ebec4c1a769d723128bf71987 100644 (file)
--- a/otherlibs/threads/unix.ml
+++ b/otherlibs/threads/unix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -192,6 +192,7 @@ type open_flag =
   | O_DSYNC
   | O_SYNC
   | O_RSYNC
+  | O_SHARE_DELETE
 
 type file_perm = int
 

diff --git a/otherlibs/unix/.cvsignore b/otherlibs/unix/.cvsignore
deleted file mode 100644 (file)
index 29fea47..0000000
--- a/otherlibs/unix/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-so_locations
-*.so
-*.a

diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend
index 42dbc3c037e2f8009a961d9c5d174a144135c901..ef8832f9b678c5ea5d9b7a9b0cd5a574a7b5ad80 100644 (file)
--- a/otherlibs/unix/.depend
+++ b/otherlibs/unix/.depend
@@ -449,9 +449,9 @@ write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
   ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \
   ../../byterun/freelist.h ../../byterun/minor_gc.h \
   ../../byterun/signals.h unixsupport.h
-unix.cmi:
-unixLabels.cmi: unix.cmi
-unix.cmo: unix.cmi
-unix.cmx: unix.cmi
-unixLabels.cmo: unix.cmi unixLabels.cmi
-unixLabels.cmx: unix.cmx unixLabels.cmi
+unix.cmi :
+unixLabels.cmi : unix.cmi
+unix.cmo : unix.cmi
+unix.cmx : unix.cmi
+unixLabels.cmo : unix.cmi unixLabels.cmi
+unixLabels.cmx : unix.cmx unixLabels.cmi

diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile
index be7234969438004d7ff89fbd4004e2044180584d..5a11b5c2c947588758c1634156161aa287516a0a 100644 (file)
--- a/otherlibs/unix/Makefile
+++ b/otherlibs/unix/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c
index a6e80f064fd75aeeddcd8b834faeeacca09ae33b..7b2688f03ead13ba2592e06fe13758ebbf44a2a6 100644 (file)
--- a/otherlibs/unix/accept.c
+++ b/otherlibs/unix/accept.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c
index 0c0c5fc1a3dc594ddc2ff34265a712e7b7f6f949..813c0634a6f6497bb53ff1f49e5298133d4fe79c 100644 (file)
--- a/otherlibs/unix/access.c
+++ b/otherlibs/unix/access.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c
index 6947d66f11c9d3b5336f88db6918beb2d633d62a..217397b508853c9f1775ecdb1cf9c5fff7c77291 100644 (file)
--- a/otherlibs/unix/addrofstr.c
+++ b/otherlibs/unix/addrofstr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/alarm.c b/otherlibs/unix/alarm.c
index 55e4d6cf80d24ef176e3b55b397363f2c449129b..6275e25564cf6ac318feb7f05573a36a4c6448d7 100644 (file)
--- a/otherlibs/unix/alarm.c
+++ b/otherlibs/unix/alarm.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c
index 85cf1d28aa370c48df6723cd6aa37258209eb22c..a6999a9f45a8416a6f0a79446bb5006d97173336 100644 (file)
--- a/otherlibs/unix/bind.c
+++ b/otherlibs/unix/bind.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c
index 7901eca0e40b141f3d5bf8ef02740ffa547cf895..2788c5054c8f6f46fb0db35a0569d9dda45310d7 100644 (file)
--- a/otherlibs/unix/chdir.c
+++ b/otherlibs/unix/chdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c
index dff837223ee5c076dfb9df9dc5abdb5adb61d414..f01d7e85b5d18b69353c7f44f6b3434ff4a9dc20 100644 (file)
--- a/otherlibs/unix/chmod.c
+++ b/otherlibs/unix/chmod.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c
index bfd164008f6770873f90d3b321d4458106543c3b..72002e9364f7449d477577fae19b6cfa793dafef 100644 (file)
--- a/otherlibs/unix/chown.c
+++ b/otherlibs/unix/chown.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c
index 24f49877d5df65de9dd79ee49d6327141050c029..879d0662f15aa43d5180535e69072f2c36e34069 100644 (file)
--- a/otherlibs/unix/chroot.c
+++ b/otherlibs/unix/chroot.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/close.c b/otherlibs/unix/close.c
index 27e1937df424d5f49c0a7b73f7e97cf4332f6892..0aaf74bd92b86f7675989a7269e35ff2a54bd0fd 100644 (file)
--- a/otherlibs/unix/close.c
+++ b/otherlibs/unix/close.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c
index b2fd51357d249b373805a3f7fbecc5c9edfef0c4..a6440efa4b306298c593140669be24454875fe69 100644 (file)
--- a/otherlibs/unix/closedir.c
+++ b/otherlibs/unix/closedir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c
index 669c347f3f3ceaa89c568b34ae203d4b0173c3ea..a17a89ffc9adfaa2e6636cc1c80ba2905c269774 100644 (file)
--- a/otherlibs/unix/connect.c
+++ b/otherlibs/unix/connect.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/cst2constr.c b/otherlibs/unix/cst2constr.c
index 9035160dcc02536410fac27f56b2610304de2ba9..8ce4d3f0d415b88ad184a212398d75bee437587d 100644 (file)
--- a/otherlibs/unix/cst2constr.c
+++ b/otherlibs/unix/cst2constr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/cst2constr.h b/otherlibs/unix/cst2constr.h
index 3cb1c11824aabecdb77f0a3ed77faf39df5a4036..e1c61a0c5f994d82443d48a78652f47ce515d2db 100644 (file)
--- a/otherlibs/unix/cst2constr.h
+++ b/otherlibs/unix/cst2constr.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c
index 0e37914d82c43bf23819f8346ab92914bfa469f2..5c83b59e44e09b598e08bd586fc846c085c71c4a 100644 (file)
--- a/otherlibs/unix/cstringv.c
+++ b/otherlibs/unix/cstringv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/dup.c b/otherlibs/unix/dup.c
index 5935d0b440241a38119126756e792dc432044f13..f78d9369dce38b044d8dfe470b0892d6ed054608 100644 (file)
--- a/otherlibs/unix/dup.c
+++ b/otherlibs/unix/dup.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/dup2.c b/otherlibs/unix/dup2.c
index beb987133b55beaa8b6c2d22cf0b496567ffbcd1..412315891f455881f56cfcfe4f9451abf81fc074 100644 (file)
--- a/otherlibs/unix/dup2.c
+++ b/otherlibs/unix/dup2.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c
index 1df842c593c76575b4ead8408697879655c58699..52e43ab7a1ba05eae839216f823ed6be46da39ae 100644 (file)
--- a/otherlibs/unix/envir.c
+++ b/otherlibs/unix/envir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -22,5 +22,9 @@ extern char ** environ;
 
 CAMLprim value unix_environment(value unit)
 {
-  return copy_string_array((const char**)environ);
+  if (environ != NULL) {
+    return copy_string_array((const char**)environ);
+  } else {
+    return Atom(0);
+  }
 }

diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c
index ae8793e196ccdf57bee17c2f7e1600727d60de5e..6cf82d6330d9feb35d28e34beec8399497757677 100644 (file)
--- a/otherlibs/unix/errmsg.c
+++ b/otherlibs/unix/errmsg.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c
index bc0330b356e149c9e0206419c2f787aec9b06cb8..51eabc712769be93537985a8ae0779811c54ed77 100644 (file)
--- a/otherlibs/unix/execv.c
+++ b/otherlibs/unix/execv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c
index 4d29fb55b730b934a7e747bb52633cd68c413c0c..00ab6af4cf96212852e91589d507aff3c6763605 100644 (file)
--- a/otherlibs/unix/execve.c
+++ b/otherlibs/unix/execve.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c
index 6d03a29ea4591d92c92a10a1d518b803c9b7d446..db77d41345d6923ed48ef09f1da988e8a3d533d6 100644 (file)
--- a/otherlibs/unix/execvp.c
+++ b/otherlibs/unix/execvp.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c
index 8f1df6d532e2ca74693295b723851d038e70b443..88fc01254721c11ed79c6ce14781b75f1445be54 100644 (file)
--- a/otherlibs/unix/exit.c
+++ b/otherlibs/unix/exit.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c
index a90de6ef1f827e60cb79fe3ea56a44f3c0dbb835..b2d49dcd468c3c3348b5d5d04ae7796c645e3d87 100644 (file)
--- a/otherlibs/unix/fchmod.c
+++ b/otherlibs/unix/fchmod.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c
index 29683a5c7977a24bd9db47f8b170fcb58726508a..e2c934ae07bea68f2a06406b60a5d161945927ba 100644 (file)
--- a/otherlibs/unix/fchown.c
+++ b/otherlibs/unix/fchown.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c
index a0891b2c30df0fd3f1e53a86aa7393824ac36394..58f7df7569b77b05e90b7649194551c0e4d460d4 100644 (file)
--- a/otherlibs/unix/fcntl.c
+++ b/otherlibs/unix/fcntl.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c
index 74ec6294d020454bb78247b08c4e437f800bd790..80b44355119af59a3938231f6693e9d4992fad7d 100644 (file)
--- a/otherlibs/unix/fork.c
+++ b/otherlibs/unix/fork.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c
index 661640e35382ced8abbc3d99bf6eab6edbe9baef..5eaa166fb16c1b85dba4cd66047b74efeed23820 100644 (file)
--- a/otherlibs/unix/ftruncate.c
+++ b/otherlibs/unix/ftruncate.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getaddrinfo.c b/otherlibs/unix/getaddrinfo.c
index adc54998a7fe8060cf0d9b108705fc562fa67bed..34cf8280c45e9b5d31a621fd57881239f5a8236c 100644 (file)
--- a/otherlibs/unix/getaddrinfo.c
+++ b/otherlibs/unix/getaddrinfo.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c
index 7c735b68dc38d944c8c47c8e65b2da69671fd31e..f3ff97114e35f7277f968569489f47055c49075d 100644 (file)
--- a/otherlibs/unix/getcwd.c
+++ b/otherlibs/unix/getcwd.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getegid.c b/otherlibs/unix/getegid.c
index 02beaf1241cc97376666bb7e72108d1ebf762fb5..9c6097ef58cf3927ec65b60652358cc1c173488d 100644 (file)
--- a/otherlibs/unix/getegid.c
+++ b/otherlibs/unix/getegid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/geteuid.c b/otherlibs/unix/geteuid.c
index 7c9f660afec9b14f1da2c1520448fe72c3bd88dc..55e0763808412747399d3b41fb76da3e70a173b5 100644 (file)
--- a/otherlibs/unix/geteuid.c
+++ b/otherlibs/unix/geteuid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getgid.c b/otherlibs/unix/getgid.c
index d0ed4bff74080fc88e8fade0b25016ec2b73a846..a3039d56cd940367b48279eb23ebe234a4bc015c 100644 (file)
--- a/otherlibs/unix/getgid.c
+++ b/otherlibs/unix/getgid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c
index eefaa5979cdde8fc3ac84a22791df3487769d523..7b212bd27914235b2f2c195bb73cbdea1e0dfc42 100644 (file)
--- a/otherlibs/unix/getgr.c
+++ b/otherlibs/unix/getgr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c
index 4d34d5be90d009565e1c0ab13e213cb9527351f0..485fabc45d3dadd1aac13a251eb5e7b5a0d8c521 100644 (file)
--- a/otherlibs/unix/getgroups.c
+++ b/otherlibs/unix/getgroups.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c
index 36fdfd8ef9e77ee4086c79dc66c683c0d0ba5496..b0b29d9e0615e76bf96758226c3f5817baeab0f6 100644 (file)
--- a/otherlibs/unix/gethost.c
+++ b/otherlibs/unix/gethost.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c
index f84f8f5b56b2659874f6412d4d1494650cfe5403..cf334e9b80dffeab66c21b93b9d42986bc91ba28 100644 (file)
--- a/otherlibs/unix/gethostname.c
+++ b/otherlibs/unix/gethostname.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getlogin.c b/otherlibs/unix/getlogin.c
index 132ed443a49f41024c875813c1ba5e763233e436..60197a07bb481ca3701515c60891cd61eb230906 100644 (file)
--- a/otherlibs/unix/getlogin.c
+++ b/otherlibs/unix/getlogin.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getnameinfo.c b/otherlibs/unix/getnameinfo.c
index c88785699351bceb6e006350525eb6c64b92c3b9..eea15c59cf2bd6bb95f370ab62a403a08c867928 100644 (file)
--- a/otherlibs/unix/getnameinfo.c
+++ b/otherlibs/unix/getnameinfo.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getpeername.c b/otherlibs/unix/getpeername.c
index 20a837ca193f98e8b8e674ee88b62ac6a6605dc1..3c4da556751dce2195ede5deb1d600cf9026c721 100644 (file)
--- a/otherlibs/unix/getpeername.c
+++ b/otherlibs/unix/getpeername.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getpid.c b/otherlibs/unix/getpid.c
index cb522749de8e134d9fff991cd8a865a46c1e2398..5cc4f3a68a43a8acb95d0b1cb91f151465a4b606 100644 (file)
--- a/otherlibs/unix/getpid.c
+++ b/otherlibs/unix/getpid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getppid.c b/otherlibs/unix/getppid.c
index 0d69aafb4a9314aa47a86d77a418d088941aca02..2d1cd394931723fc3b9f50bce084b9fe25960239 100644 (file)
--- a/otherlibs/unix/getppid.c
+++ b/otherlibs/unix/getppid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c
index c9ca1a5c9eaaff270b45f9d5c438db7e5af8210b..0213e8795a2839305cb83a219e1d0281907ff1ed 100644 (file)
--- a/otherlibs/unix/getproto.c
+++ b/otherlibs/unix/getproto.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c
index eba9d6c3c329782a8b1248c495d9085aba87dd7a..4317dc202f51a8ffb84d1b61fd4f8e61476c68ba 100644 (file)
--- a/otherlibs/unix/getpw.c
+++ b/otherlibs/unix/getpw.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c
index e252aacb70a306c19a00be9eebec076d78fe1bfd..626f63b8a6876e3b6da78dcbcb5208c0ff269603 100644 (file)
--- a/otherlibs/unix/getserv.c
+++ b/otherlibs/unix/getserv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getsockname.c b/otherlibs/unix/getsockname.c
index 6f0b64dcd3d54b8ad11ae079c1d0d8131d96ea49..8ab6debb09cb38cc65abb090ec2bbf3a0314dbe0 100644 (file)
--- a/otherlibs/unix/getsockname.c
+++ b/otherlibs/unix/getsockname.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c
index e095326e676b9785fb389d0a9c77b644fe34ee63..3e203d54e0e58e90f535f90132a45cc3543ed116 100644 (file)
--- a/otherlibs/unix/gettimeofday.c
+++ b/otherlibs/unix/gettimeofday.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/getuid.c b/otherlibs/unix/getuid.c
index 780a8d8ec455c9d2a6cffa5e698779a3fac9731a..db3fab130e5a0d0b85b5a2c14f815bd6ce7b1f60 100644 (file)
--- a/otherlibs/unix/getuid.c
+++ b/otherlibs/unix/getuid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c
index 2ffeb3927b158770ef521f28fac49b02a6977ad4..b55d70f4d99b1ffd60c2470dafcc2dc348cb5586 100644 (file)
--- a/otherlibs/unix/gmtime.c
+++ b/otherlibs/unix/gmtime.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/initgroups.c b/otherlibs/unix/initgroups.c
index df358dae16d4d7be310945d986caca6c2a8ad780..d5b3dc5680dd294c5fbed5432d2545f2bd1c70ba 100644 (file)
--- a/otherlibs/unix/initgroups.c
+++ b/otherlibs/unix/initgroups.c
@@ -1,6 +1,8 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
+/*                                                                     */
+/*  Contributed by Stephane Glondu <steph@glondu.net>                  */
 /*                                                                     */
 /*  Copyright 2009 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
@@ -9,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* Contributed by Stephane Glondu <steph@glondu.net> */
-
 /* $Id$ */
 
 #include <mlvalues.h>

diff --git a/otherlibs/unix/isatty.c b/otherlibs/unix/isatty.c
index f534dd773b3c3c08340b258495ebcad3543111e4..c2bdaad1c15e1a045aa24aa6a3ebe98004ba6f9d 100644 (file)
--- a/otherlibs/unix/isatty.c
+++ b/otherlibs/unix/isatty.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Gallium, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/itimer.c b/otherlibs/unix/itimer.c
index 14bac626abed7b3c5b011c419e5cac7c6c858ae9..7c32783a9bb7a608381350206922df85d0287393 100644 (file)
--- a/otherlibs/unix/itimer.c
+++ b/otherlibs/unix/itimer.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c
index 8d8a47340ceff76eced1b7021fcf6a88f0dee42d..715060ee7801092c8f9151fbdca85b67fce90013 100644 (file)
--- a/otherlibs/unix/kill.c
+++ b/otherlibs/unix/kill.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c
index 181e9c1800478a3585278b55096fb2653b8bbc4f..e28f649ea051357dabe2092514bedcd7182233dc 100644 (file)
--- a/otherlibs/unix/link.c
+++ b/otherlibs/unix/link.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c
index 2f40cfbafadde176b9515f48dea65c3020323a01..503cf6a6ad6f47d6f051dd5cae014f6fea14ec20 100644 (file)
--- a/otherlibs/unix/listen.c
+++ b/otherlibs/unix/listen.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c
index 6e6ce5c1730ee8604d30008534894545044b5aaf..70359cf76d6f6a053b981dbfa91940e613627068 100644 (file)
--- a/otherlibs/unix/lockf.c
+++ b/otherlibs/unix/lockf.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c
index d8180eaea6c2a05be91a169967c49cd0cbd1eb1f..65d7d50e407da7b5875735410cd7ff3efdfecff6 100644 (file)
--- a/otherlibs/unix/lseek.c
+++ b/otherlibs/unix/lseek.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c
index 1b8fd6242f72e2680e0dbcff31504baf2e8a6703..fd935ae67aba8f6ae6931070519e97430aa6d13e 100644 (file)
--- a/otherlibs/unix/mkdir.c
+++ b/otherlibs/unix/mkdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c
index 3e2cf3ddb5eddb6267a531fcec9be60d87abe5aa..30f247d90f585142f73404cfeab92e2e77411710 100644 (file)
--- a/otherlibs/unix/mkfifo.c
+++ b/otherlibs/unix/mkfifo.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c
index 77def267c1b611d01d7f94a7d65042505b54ee1b..a0902f230912138d2b28580eef21a5e337c75d56 100644 (file)
--- a/otherlibs/unix/nice.c
+++ b/otherlibs/unix/nice.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c
index 421218308c68f8d9cd565fa339776616baa20b43..214a550d3667ba22c88b4d2a231ce36e6eca58a1 100644 (file)
--- a/otherlibs/unix/open.c
+++ b/otherlibs/unix/open.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -36,7 +36,7 @@
 
 static int open_flag_table[] = {
   O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
-  O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC
+  O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0
 };
 
 CAMLprim value unix_open(value path, value flags, value perm)

diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c
index 0497ef1f4ffd4af10ae38bece7ee8613b467f09b..bb4825812c56a15735ccbc5eb99a3634259b009a 100644 (file)
--- a/otherlibs/unix/opendir.c
+++ b/otherlibs/unix/opendir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/pipe.c b/otherlibs/unix/pipe.c
index b68705e9ff2887b56f5979549be89324b137f148..81baeaf4e112e2dcad503824d9adf773358d182e 100644 (file)
--- a/otherlibs/unix/pipe.c
+++ b/otherlibs/unix/pipe.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c
index e403d2966f96063bda9cb215bef864c13416d6ed..1238ee2b69d81511836329437e3aec60d3bdefb6 100644 (file)
--- a/otherlibs/unix/putenv.c
+++ b/otherlibs/unix/putenv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -28,13 +28,16 @@ CAMLprim value unix_putenv(value name, value val)
 {
   mlsize_t namelen = string_length(name);
   mlsize_t vallen = string_length(val);
-  char * s = (char *) stat_alloc(namelen + 1 + vallen + 1);
+  char * s = (char *) caml_stat_alloc(namelen + 1 + vallen + 1);
 
   memmove (s, String_val(name), namelen);
   s[namelen] = '=';
   memmove (s + namelen + 1, String_val(val), vallen);
   s[namelen + 1 + vallen] = 0;
-  if (putenv(s) == -1) uerror("putenv", name);
+  if (putenv(s) == -1) {
+    caml_stat_free(s);
+    uerror("putenv", name);
+  }
   return Val_unit;
 }
 

diff --git a/otherlibs/unix/read.c b/otherlibs/unix/read.c
index 03a9e6aaa70de2305449fac3f378cfb05e529acf..cd1eab8cf640952278f3625d9541a9e0ee532670 100644 (file)
--- a/otherlibs/unix/read.c
+++ b/otherlibs/unix/read.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/readdir.c b/otherlibs/unix/readdir.c
index fb8a67b20e5d8fe702f2b541cebb716bfbe9edee..1d508ac6eb4e0453df0ff1fe902b1c71e8cdb2ad 100644 (file)
--- a/otherlibs/unix/readdir.c
+++ b/otherlibs/unix/readdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c
index d2b9c4e125929da061279be0c187581cfc1ef8f9..29d28d3d4a61caf1ad2add189212c19fccadb507 100644 (file)
--- a/otherlibs/unix/readlink.c
+++ b/otherlibs/unix/readlink.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c
index 65f33c8b57fd89793145646069ffbcd1768373e3..d121037f27c126865dc5233cef879f73d78821cb 100644 (file)
--- a/otherlibs/unix/rename.c
+++ b/otherlibs/unix/rename.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c
index d14c526d963b53292d51cd65541a5d07f67aa766..7c7b4a3c898f6c9df3c168f856df0892416bf31b 100644 (file)
--- a/otherlibs/unix/rewinddir.c
+++ b/otherlibs/unix/rewinddir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c
index 8de223464db2c7d1585bb54f2766d28ba134a4ac..887496712d4ec53351a9c15c97f388878b8d1343 100644 (file)
--- a/otherlibs/unix/rmdir.c
+++ b/otherlibs/unix/rmdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c
index 612d59701420e71650b85379785f8e1533b9aaaa..0493839861fdb6a5496f7a0e5342a873087f758a 100644 (file)
--- a/otherlibs/unix/select.c
+++ b/otherlibs/unix/select.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c
index bb3989af7804a27f0a24b9fa7212cadd0e741116..1f884aa87d090da1d229a8d3704bc422851f9807 100644 (file)
--- a/otherlibs/unix/sendrecv.c
+++ b/otherlibs/unix/sendrecv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/setgid.c b/otherlibs/unix/setgid.c
index bd8810f819fc443edc6e9d78bd864f147a8e8275..a1096f26ba3d357235d1c37e6c966270e016891a 100644 (file)
--- a/otherlibs/unix/setgid.c
+++ b/otherlibs/unix/setgid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/setgroups.c b/otherlibs/unix/setgroups.c
index dd4592ad00f686bad950c15389f0e233d042a4f9..e681c97647a90e83b10fca694f8c42ab2b397eb6 100644 (file)
--- a/otherlibs/unix/setgroups.c
+++ b/otherlibs/unix/setgroups.c
@@ -1,6 +1,8 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
+/*                                                                     */
+/* Contributed by Stephane Glondu <steph@glondu.net>                   */
 /*                                                                     */
 /*  Copyright 2009 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
@@ -9,8 +11,6 @@
 /*                                                                     */
 /***********************************************************************/
 
-/* Contributed by Stephane Glondu <steph@glondu.net> */
-
 /* $Id$ */
 
 #include <mlvalues.h>

diff --git a/otherlibs/unix/setsid.c b/otherlibs/unix/setsid.c
index bfa9dac0b2fc177a4454f9fbb73b7ffbdf6d73a1..9cc89e642ce30c9bdea2d335c30ec7d08d82c0ca 100644 (file)
--- a/otherlibs/unix/setsid.c
+++ b/otherlibs/unix/setsid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/setuid.c b/otherlibs/unix/setuid.c
index c867f4c68b08079847e9de186e773a1544f32c1c..4af0d781c95226c75e2f884e9eda4fb45d3683f9 100644 (file)
--- a/otherlibs/unix/setuid.c
+++ b/otherlibs/unix/setuid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/shutdown.c b/otherlibs/unix/shutdown.c
index d51b1a3de936156fcbc3221eb61f0f982df18f91..abd8c07344d4b107c9bb5fcdc427dff7c0b64979 100644 (file)
--- a/otherlibs/unix/shutdown.c
+++ b/otherlibs/unix/shutdown.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c
index c388b139367fbb5d060d9cb6b2da2a88310e2b97..fb3acf00bf856136d24888572b1d181fd3c7f6de 100644 (file)
--- a/otherlibs/unix/signals.c
+++ b/otherlibs/unix/signals.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c
index ec14e39d0be9c71f094375317cd0685799c891fa..aca1003c5cf9a96d40ee008d0be8e67551146598 100644 (file)
--- a/otherlibs/unix/sleep.c
+++ b/otherlibs/unix/sleep.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c
index 82f6329c03727751c7e73afd154f863067359476..7243b8f15b12e0ff70dab271a1370fcedce5f756 100644 (file)
--- a/otherlibs/unix/socket.c
+++ b/otherlibs/unix/socket.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c
index f285d15a7b0c918442f3e16ebe0f73593ffe76d0..caf83b785ed513bb8bd50dca04395bcc7817fb1d 100644 (file)
--- a/otherlibs/unix/socketaddr.c
+++ b/otherlibs/unix/socketaddr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h
index 79bc80fa7af69c984ee965217d87d760eacecf2c..43d7e91b4fafc0dfb23d099f952ade4a24a9292c 100644 (file)
--- a/otherlibs/unix/socketaddr.h
+++ b/otherlibs/unix/socketaddr.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c
index df4dcff036938200d68233e425bdb99bdd9554b7..8a52dbb81b7ecd2afa3b98842266a87ca863a9ff 100644 (file)
--- a/otherlibs/unix/socketpair.c
+++ b/otherlibs/unix/socketpair.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c
index 31c95c1f55dff66fcd1cca2632e56f0bbeea8e9a..6b3bfa4a4bcb48df7e6b826ca6917af095af27f2 100644 (file)
--- a/otherlibs/unix/sockopt.c
+++ b/otherlibs/unix/sockopt.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c
index 9cd0000632693358d2c0955716c4c1e5ea6a374e..17ae53c0b2cffc43aa281da7cf9115146d521f9c 100644 (file)
--- a/otherlibs/unix/stat.c
+++ b/otherlibs/unix/stat.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c
index ad9ea1911755a1f73cfe22cdbf9b3259daaea534..a2c8cdc732d2c63fede5bbf22cf08038aa077b8d 100644 (file)
--- a/otherlibs/unix/strofaddr.c
+++ b/otherlibs/unix/strofaddr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c
index 6085fd516de5b0e47d7fc93c0bc96e21a359d09e..b66c76bda10e160af787026a0ecabc7138fd2e8f 100644 (file)
--- a/otherlibs/unix/symlink.c
+++ b/otherlibs/unix/symlink.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c
index ce49d77e09ac260f7f4bcfe546a4f7b3d493226f..99cca2b64369dc844af52b1bc6b2d3c743feaccd 100644 (file)
--- a/otherlibs/unix/termios.c
+++ b/otherlibs/unix/termios.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c
index 2fdf4978e4f022edca97ce9f53be3021386a2f3b..63eac84eb75475564aaa2c128b8d1baa127c13a5 100644 (file)
--- a/otherlibs/unix/time.c
+++ b/otherlibs/unix/time.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c
index aa32f10db059c38a456c6dd48756136b0a08fcf4..94abde8a6dc6ecf3d1f2ab906a547e2f592c30cc 100644 (file)
--- a/otherlibs/unix/times.c
+++ b/otherlibs/unix/times.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c
index c23eb47b526f407a6444b2039d6bdfb89d47c36b..dfc350a3294864e7943347de73dacc689b03d1fc 100644 (file)
--- a/otherlibs/unix/truncate.c
+++ b/otherlibs/unix/truncate.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/umask.c b/otherlibs/unix/umask.c
index 6f5d14fd0c3efb17c43dad6eb4572a27aa4a5fd3..cf5eaa7c0808d296af48f2789616ac2fcfb4da85 100644 (file)
--- a/otherlibs/unix/umask.c
+++ b/otherlibs/unix/umask.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index 8de827b0c860ace84d5627591814247deb18f79a..0adc41e213b66d8063950de9a0b5336a0cb5e798 100644 (file)
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -151,6 +151,7 @@ type open_flag =
   | O_DSYNC
   | O_SYNC
   | O_RSYNC
+  | O_SHARE_DELETE
 
 type file_perm = int
 
@@ -838,27 +839,47 @@ let open_proc cmd proc input output toclose =
 let open_process_in cmd =
   let (in_read, in_write) = pipe() in
   let inchan = in_channel_of_descr in_read in
-  open_proc cmd (Process_in inchan) stdin in_write [in_read];
+  begin
+    try
+      open_proc cmd (Process_in inchan) stdin in_write [in_read];
+    with e ->
+      close_in inchan;
+      close in_write;
+      raise e
+  end;
   close in_write;
   inchan
 
 let open_process_out cmd =
   let (out_read, out_write) = pipe() in
   let outchan = out_channel_of_descr out_write in
-  open_proc cmd (Process_out outchan) out_read stdout [out_write];
+  begin
+    try
+      open_proc cmd (Process_out outchan) out_read stdout [out_write];
+    with e ->
+      close_out outchan;
+      close out_read;
+      raise e
+  end;
   close out_read;
   outchan
 
 let open_process cmd =
   let (in_read, in_write) = pipe() in
-  let (out_read, out_write) = pipe() in
-  let inchan = in_channel_of_descr in_read in
-  let outchan = out_channel_of_descr out_write in
-  open_proc cmd (Process(inchan, outchan)) out_read in_write
+  let fds_to_close = ref [in_read;in_write] in
+  try
+    let (out_read, out_write) = pipe() in
+    fds_to_close := [in_read;in_write;out_read;out_write];
+    let inchan = in_channel_of_descr in_read in
+    let outchan = out_channel_of_descr out_write in
+    open_proc cmd (Process(inchan, outchan)) out_read in_write
                                            [in_read; out_write];
-  close out_read;
-  close in_write;
-  (inchan, outchan)
+    close out_read;
+    close in_write;
+    (inchan, outchan)
+  with e ->
+    List.iter close !fds_to_close;
+    raise e
 
 let open_proc_full cmd env proc input output error toclose =
   let cloexec = List.for_all try_set_close_on_exec toclose in
@@ -874,17 +895,24 @@ let open_proc_full cmd env proc input output error toclose =
 
 let open_process_full cmd env =
   let (in_read, in_write) = pipe() in
-  let (out_read, out_write) = pipe() in
-  let (err_read, err_write) = pipe() in
-  let inchan = in_channel_of_descr in_read in
-  let outchan = out_channel_of_descr out_write in
-  let errchan = in_channel_of_descr err_read in
-  open_proc_full cmd env (Process_full(inchan, outchan, errchan))
-                 out_read in_write err_write [in_read; out_write; err_read];
-  close out_read;
-  close in_write;
-  close err_write;
-  (inchan, outchan, errchan)
+  let fds_to_close = ref [in_read;in_write] in
+  try
+    let (out_read, out_write) = pipe() in
+    fds_to_close := out_read::out_write:: !fds_to_close;
+    let (err_read, err_write) = pipe() in
+    fds_to_close := err_read::err_write:: !fds_to_close;
+    let inchan = in_channel_of_descr in_read in
+    let outchan = out_channel_of_descr out_write in
+    let errchan = in_channel_of_descr err_read in
+    open_proc_full cmd env (Process_full(inchan, outchan, errchan))
+      out_read in_write err_write [in_read; out_write; err_read];
+    close out_read;
+    close in_write;
+    close err_write;
+    (inchan, outchan, errchan)
+  with e ->
+    List.iter close !fds_to_close;
+    raise e
 
 let find_proc_id fun_name proc =
   try

diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index 614c206f263ede301bba4c9c48539e55a349e41d..0c2780999a5ffeeb41c79d478855091506c962f6 100644 (file)
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -122,7 +122,7 @@ val environment : unit -> string array
 val getenv : string -> string
 (** Return the value associated to a variable in the process
    environment. Raise [Not_found] if the variable is unbound.
-   (This function is identical to [Sys.getenv].) *)
+   (This function is identical to {!Sys.getenv}.) *)
 
 val putenv : string -> string -> unit
 (** [Unix.putenv name value] sets the value associated to a
@@ -235,9 +235,14 @@ type open_flag =
   | O_TRUNC                     (** Truncate to 0 length if existing *)
   | O_EXCL                      (** Fail if existing *)
   | O_NOCTTY                    (** Don't make this dev a controlling tty *)
-  | O_DSYNC                     (** Writes complete as `Synchronised I/O data integrity completion' *)
-  | O_SYNC                      (** Writes complete as `Synchronised I/O file integrity completion' *)
-  | O_RSYNC                     (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
+  | O_DSYNC                     (** Writes complete as `Synchronised I/O data
+                                   integrity completion' *)
+  | O_SYNC                      (** Writes complete as `Synchronised I/O file
+                                   integrity completion' *)
+  | O_RSYNC                     (** Reads complete as writes (depending on
+                                   O_SYNC/O_DSYNC) *)
+  | O_SHARE_DELETE              (** Windows only: allow the file to be deleted
+                                   while still open *)
 (** The flags to {!Unix.openfile}. *)
 
 
@@ -765,9 +770,11 @@ val utimes : string -> float -> float -> unit
 
 type interval_timer =
     ITIMER_REAL
-      (** decrements in real time, and sends the signal [SIGALRM] when expired.*)
+      (** decrements in real time, and sends the signal [SIGALRM] when
+         expired.*)
   | ITIMER_VIRTUAL
-      (**  decrements in process virtual time, and sends [SIGVTALRM] when expired. *)
+      (** decrements in process virtual time, and sends [SIGVTALRM]
+          when expired. *)
   | ITIMER_PROF
       (** (for profiling) decrements both when the process
          is running and when the system is running on behalf of the
@@ -1022,8 +1029,9 @@ type socket_int_option =
   | SO_RCVBUF      (** Size of received buffer *)
   | SO_ERROR       (** Deprecated.  Use {!Unix.getsockopt_error} instead. *)
   | SO_TYPE        (** Report the socket type *)
-  | SO_RCVLOWAT    (** Minimum number of bytes to process for input operations *)
-  | SO_SNDLOWAT    (** Minimum number of bytes to process for output operations *)
+  | SO_RCVLOWAT    (** Minimum number of bytes to process for input operations*)
+  | SO_SNDLOWAT    (** Minimum number of bytes to process for output
+                       operations *)
 (** The socket options that can be consulted with {!Unix.getsockopt_int}
    and modified with {!Unix.setsockopt_int}.  These options have an
    integer value. *)
@@ -1058,17 +1066,21 @@ val setsockopt_int : file_descr -> socket_int_option -> int -> unit
 (** Same as {!Unix.setsockopt} for an integer-valued socket option. *)
 
 val getsockopt_optint : file_descr -> socket_optint_option -> int option
-(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *)
+(** Same as {!Unix.getsockopt} for a socket option whose value is an
+   [int option]. *)
 
 val setsockopt_optint :
       file_descr -> socket_optint_option -> int option -> unit
-(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *)
+(** Same as {!Unix.setsockopt} for a socket option whose value is an
+   [int option]. *)
 
 val getsockopt_float : file_descr -> socket_float_option -> float
-(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *)
+(** Same as {!Unix.getsockopt} for a socket option whose value is a
+   floating-point number. *)
 
 val setsockopt_float : file_descr -> socket_float_option -> float -> unit
-(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *)
+(** Same as {!Unix.setsockopt} for a socket option whose value is a
+   floating-point number. *)
 
 val getsockopt_error : file_descr -> error option
 (** Return the error condition associated with the given socket,

diff --git a/otherlibs/unix/unixLabels.ml b/otherlibs/unix/unixLabels.ml
index 683f15ec6752fa47d860803bd9edc85043955c1a..424fcc6e629cc359ca982c9fbb8e29122a6293c0 100644 (file)
--- a/otherlibs/unix/unixLabels.ml
+++ b/otherlibs/unix/unixLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)

diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli
index 7126d23e70fcf8258538ac3869c864994621e600..98a58f1b90f57de39a1c141617dac33a9c14ae51 100644 (file)
--- a/otherlibs/unix/unixLabels.mli
+++ b/otherlibs/unix/unixLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -240,6 +240,7 @@ type open_flag = Unix.open_flag =
   | O_DSYNC                     (** Writes complete as `Synchronised I/O data integrity completion' *)
   | O_SYNC                      (** Writes complete as `Synchronised I/O file integrity completion' *)
   | O_RSYNC                     (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *)
+  | O_SHARE_DELETE              (** Windows only: allow the file to be deleted while still open *)
 (** The flags to {!UnixLabels.openfile}. *)
 
 

diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c
index c6eaf706c5502c3e58cc1533da13e75012ae84bd..4c91adb1041d2d89f6efcfe67c67a35cd7dbb800 100644 (file)
--- a/otherlibs/unix/unixsupport.c
+++ b/otherlibs/unix/unixsupport.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -165,7 +165,11 @@
 #define ESOCKTNOSUPPORT (-1)
 #endif
 #ifndef EOPNOTSUPP
-#define EOPNOTSUPP (-1)
+#  ifdef ENOTSUP
+#    define EOPNOTSUPP ENOTSUP
+#  else
+#    define EOPNOTSUPP (-1)
+#  endif
 #endif
 #ifndef EPFNOSUPPORT
 #define EPFNOSUPPORT (-1)
@@ -252,6 +256,11 @@ value unix_error_of_code (int errcode)
   int errconstr;
   value err;
 
+#if defined(ENOTSUP) && (EOPNOTSUPP != ENOTSUP)
+  if (errcode == ENOTSUP)
+    errcode = EOPNOTSUPP;
+#endif
+
   errconstr =
       cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
   if (errconstr == Val_int(-1)) {

diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h
index 84179f43f31d14ec0e857c3060aa519e8564af5b..a90bb2dcf20cf0aecf3dfae10396b1a178b71024 100644 (file)
--- a/otherlibs/unix/unixsupport.h
+++ b/otherlibs/unix/unixsupport.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c
index 1d956758b305b3f0c4d73a2de8b9d5e26dadb845..3fb5151be030b93265b8309ac8ba08a0437b1d63 100644 (file)
--- a/otherlibs/unix/unlink.c
+++ b/otherlibs/unix/unlink.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c
index da2913570a359a25b8e90ab2d331594c1a54a7f6..a6a2f5ebc59e226e786a480920a73d17f146ea1d 100644 (file)
--- a/otherlibs/unix/utimes.c
+++ b/otherlibs/unix/utimes.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c
index 486d06af7b207a578e844491154fe8a5911bb1ed..fc12e5ad5c4ea255db116ee4c81149ccec194ada 100644 (file)
--- a/otherlibs/unix/wait.c
+++ b/otherlibs/unix/wait.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c
index 9ddf74e3d5c05bebd714daa6b64b41174ce7e187..ca42d1e75be6200405bad0fc72fb5b652bc141e3 100644 (file)
--- a/otherlibs/unix/write.c
+++ b/otherlibs/unix/write.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32graph/.cvsignore b/otherlibs/win32graph/.cvsignore
deleted file mode 100644 (file)
index 090a9a2..0000000
--- a/otherlibs/win32graph/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-graphics.ml
-graphics.mli

diff --git a/otherlibs/win32graph/.ignore b/otherlibs/win32graph/.ignore
new file mode 100644 (file)
index 0000000..090a9a2
--- /dev/null
+++ b/otherlibs/win32graph/.ignore
@@ -0,0 +1,2 @@
+graphics.ml
+graphics.mli

diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt
index 12e3d23925b11b77ad07c2b28a75c3b7a68ab47f..453d9f3c850b5406d6902f38dbe3f43b82821031 100644 (file)
--- a/otherlibs/win32graph/Makefile.nt
+++ b/otherlibs/win32graph/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/otherlibs/win32graph/dib.c b/otherlibs/win32graph/dib.c
index cbf4725a4310d06659b36035d30066171a20265e..8acba6f1327644536cccb1f878689bd4c93e0b07 100644 (file)
--- a/otherlibs/win32graph/dib.c
+++ b/otherlibs/win32graph/dib.c
@@ -1,8 +1,9 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Developed by Jacob Navia                                           */
+/*                                                                     */
 /*  Copyright 2001 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
 /*  under the terms of the GNU Library General Public License, with    */

diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c
index 62710ec09d1f895b054016504f3ae88459d76cb0..f089a01a32fa3ce8c9a3149e43054412f87e56e9 100644 (file)
--- a/otherlibs/win32graph/draw.c
+++ b/otherlibs/win32graph/draw.c
@@ -1,8 +1,9 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */
+/*                                                                     */
 /*  Copyright 2001 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
 /*  under the terms of the GNU Library General Public License, with    */
@@ -452,7 +453,8 @@ static struct custom_operations image_ops = {
         custom_compare_default,
         custom_hash_default,
         custom_serialize_default,
-        custom_deserialize_default
+        custom_deserialize_default,
+        custom_compare_ext_default
 };
 
 CAMLprim value caml_gr_create_image(value vw, value vh)

diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c
index 9e0791c389e8a35e5e1a858423b09a965d51c350..29def467ffe5b6afd59cd118625995e292c63249 100755 (executable)
--- a/otherlibs/win32graph/events.c
+++ b/otherlibs/win32graph/events.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h
index 6c32f15df690785ea2ba3f0e7cb4451617a19dfc..bae4b1162350cbc770136b5ce03d16e5363484cf 100644 (file)
--- a/otherlibs/win32graph/libgraph.h
+++ b/otherlibs/win32graph/libgraph.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Jacob Navia, after Xavier Leroy                          */
 /*                                                                     */
@@ -43,8 +43,8 @@ extern int bits_per_pixel;
 #define DEFAULT_SCREEN_WIDTH 1024
 #define DEFAULT_SCREEN_HEIGHT 768
 #define BORDER_WIDTH 2
-#define WINDOW_NAME "Caml graphics"
-#define ICON_NAME "Caml graphics"
+#define WINDOW_NAME "OCaml graphics"
+#define ICON_NAME "OCaml graphics"
 #define SIZE_QUEUE 256
 
 void gr_fail(char *fmt, char *arg);

diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c
index 2797bc669a6aa2d774de923ba1e911f7da71aad4..a6bc59d45f0ef33d05a00df28f9da647fcf0c627 100644 (file)
--- a/otherlibs/win32graph/open.c
+++ b/otherlibs/win32graph/open.c
@@ -1,8 +1,9 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Developed by Jacob Navia, based on code by J-M Geffroy and X Leroy */
+/*                                                                     */
 /*  Copyright 2001 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
 /*  under the terms of the GNU Library General Public License, with    */
@@ -237,7 +238,7 @@ static DWORD WINAPI gr_open_graph_internal(value arg)
   caml_gr_init_event_queue();
 
   /* The global data structures are now correctly initialized.
-     Restart the Caml main thread. */
+     Restart the OCaml main thread. */
   open_graph_errmsg = NULL;
   SetEvent(open_graph_event);
 

diff --git a/otherlibs/win32unix/.cvsignore b/otherlibs/win32unix/.cvsignore
deleted file mode 100644 (file)
index e85bbd9..0000000
--- a/otherlibs/win32unix/.cvsignore
+++ /dev/null
@@ -1,27 +0,0 @@
-unixLabels.ml*
-unix.mli
-unix.lib
-access.c
-addrofstr.c
-chdir.c
-chmod.c
-cst2constr.c
-cstringv.c
-envir.c
-execv.c
-execve.c
-execvp.c
-exit.c
-getcwd.c
-gethost.c
-gethostname.c
-getproto.c
-getserv.c
-gmtime.c
-putenv.c
-rmdir.c
-socketaddr.c
-strofaddr.c
-time.c
-unlink.c
-utimes.c

diff --git a/otherlibs/win32unix/.ignore b/otherlibs/win32unix/.ignore
new file mode 100644 (file)
index 0000000..e85bbd9
--- /dev/null
+++ b/otherlibs/win32unix/.ignore
@@ -0,0 +1,27 @@
+unixLabels.ml*
+unix.mli
+unix.lib
+access.c
+addrofstr.c
+chdir.c
+chmod.c
+cst2constr.c
+cstringv.c
+envir.c
+execv.c
+execve.c
+execvp.c
+exit.c
+getcwd.c
+gethost.c
+gethostname.c
+getproto.c
+getserv.c
+gmtime.c
+putenv.c
+rmdir.c
+socketaddr.c
+strofaddr.c
+time.c
+unlink.c
+utimes.c

diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
index 0d98b316955e1e61adeea11315702647560dfe15..84f1574a3405814282c45c2efd81544c435b6cef 100644 (file)
--- a/otherlibs/win32unix/Makefile.nt
+++ b/otherlibs/win32unix/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -21,7 +21,7 @@ WIN_FILES = accept.c bind.c channels.c close.c \
   mkdir.c open.c pipe.c read.c rename.c \
   select.c sendrecv.c \
   shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
-  system.c unixsupport.c windir.c winwait.c write.c \
+  system.c times.c unixsupport.c windir.c winwait.c write.c \
   winlist.c winworker.c windbug.c
 
 # Files from the ../unix directory

diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c
index 1d54b89b327807f16cffc405abf0933e6e5c00aa..68c7bac7afab6965e38cecda6607782b2f4a13e9 100644 (file)
--- a/otherlibs/win32unix/accept.c
+++ b/otherlibs/win32unix/accept.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -26,30 +26,15 @@ CAMLprim value unix_accept(sock)
   SOCKET sconn = Socket_val(sock);
   SOCKET snew;
   value fd = Val_unit, adr = Val_unit, res;
-  int oldvalue, oldvaluelen, newvalue, retcode;
   union sock_addr_union addr;
   socklen_param_type addr_len;
   DWORD err = 0;
 
-  oldvaluelen = sizeof(oldvalue);
-  retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-                       (char *) &oldvalue, &oldvaluelen);
-  if (retcode == 0) {
-    /* Set sockets to synchronous mode */
-    newvalue = SO_SYNCHRONOUS_NONALERT;
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *) &newvalue, sizeof(newvalue));
-  }
   addr_len = sizeof(sock_addr);
   enter_blocking_section();
   snew = accept(sconn, &addr.s_gen, &addr_len);
   if (snew == INVALID_SOCKET) err = WSAGetLastError ();
   leave_blocking_section();
-  if (retcode == 0) {
-    /* Restore initial mode */
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *) &oldvalue, oldvaluelen);
-  }
   if (snew == INVALID_SOCKET) {
     win32_maperr(err);
     uerror("accept", Nothing);

diff --git a/otherlibs/win32unix/bind.c b/otherlibs/win32unix/bind.c
index fca969489016308a2fd2f38537bf41e21ef6fb3d..84d07570c34f99922c3da42e339b2d31b8127ade 100644 (file)
--- a/otherlibs/win32unix/bind.c
+++ b/otherlibs/win32unix/bind.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c
index 56a19c7dc3c78ee15d3ea80463e86a428d515516..ea3912720d0fe6da6eaf8f820307672bfa53df63 100644 (file)
--- a/otherlibs/win32unix/channels.c
+++ b/otherlibs/win32unix/channels.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -20,15 +20,15 @@
 #include "unixsupport.h"
 #include <fcntl.h>
 
-extern long _get_osfhandle(int);
-extern int _open_osfhandle(long, int);
+extern intptr_t _get_osfhandle(int);
+extern int _open_osfhandle(intptr_t, int);
 
 int win_CRT_fd_of_filedescr(value handle)
 {
   if (CRT_fd_val(handle) != NO_CRT_FD) {
     return CRT_fd_val(handle);
   } else {
-    int fd = _open_osfhandle((long) Handle_val(handle), O_BINARY);
+    int fd = _open_osfhandle((intptr_t) Handle_val(handle), O_BINARY);
     if (fd == -1) uerror("channel_of_descr", Nothing);
     CRT_fd_val(handle) = fd;
     return fd;

diff --git a/otherlibs/win32unix/close.c b/otherlibs/win32unix/close.c
index 21254ef1e16399667b3e6c3c17695b06c803f4d8..f7463690b606f02dbec690beac54a7ee174fcba1 100644 (file)
--- a/otherlibs/win32unix/close.c
+++ b/otherlibs/win32unix/close.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/close_on.c b/otherlibs/win32unix/close_on.c
index 5b2c4ece329eb6411a33980881a75ccd8842f71b..03ff2b894c06f27f7a3ad5ac181b390006507700 100644 (file)
--- a/otherlibs/win32unix/close_on.c
+++ b/otherlibs/win32unix/close_on.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
@@ -19,17 +19,14 @@
 
 int win_set_inherit(value fd, BOOL inherit)
 {
-  HANDLE oldh, newh;
-
-  oldh = Handle_val(fd);
-  if (! DuplicateHandle(GetCurrentProcess(), oldh,
-                        GetCurrentProcess(), &newh,
-                        0L, inherit, DUPLICATE_SAME_ACCESS)) {
+  /* According to the MSDN, SetHandleInformation may not work
+     for console handles on WinNT4 and earlier versions. */
+  if (! SetHandleInformation(Handle_val(fd),
+                            HANDLE_FLAG_INHERIT,
+                            inherit ? HANDLE_FLAG_INHERIT : 0)) {
     win32_maperr(GetLastError());
     return -1;
   }
-  Handle_val(fd) = newh;
-  CloseHandle(oldh);
   return 0;
 }
 

diff --git a/otherlibs/win32unix/connect.c b/otherlibs/win32unix/connect.c
index 198d02e2de507a6ba381fda7a947e9cd9f898490..bd342a2ea87d3076424b67716ed08afcbdef3889 100644 (file)
--- a/otherlibs/win32unix/connect.c
+++ b/otherlibs/win32unix/connect.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c
index 042eaef9e72999944752606b5d91a51bf3181338..714513cacb8ad79c1fc5922527a0c0ae5802e292 100644 (file)
--- a/otherlibs/win32unix/createprocess.c
+++ b/otherlibs/win32unix/createprocess.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/dup.c b/otherlibs/win32unix/dup.c
index 2668e75bf14405bd6ede17f2174e00e06f59c634..a86211bbb17a6816d8f9a0a41bef34f85de5a304 100644 (file)
--- a/otherlibs/win32unix/dup.c
+++ b/otherlibs/win32unix/dup.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/dup2.c b/otherlibs/win32unix/dup2.c
index 3f6d37e76de46255e04203c7767f61641567220a..f224fc54e716794a459f5abf3fc6b50ef95f7ed4 100644 (file)
--- a/otherlibs/win32unix/dup2.c
+++ b/otherlibs/win32unix/dup2.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/errmsg.c b/otherlibs/win32unix/errmsg.c
index 9ce9dddb2aee8afab384b11232a28f21a873175d..1f07e514fd8ed3e917bd3ae43fbc5782ec1eb1b6 100644 (file)
--- a/otherlibs/win32unix/errmsg.c
+++ b/otherlibs/win32unix/errmsg.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/getpeername.c b/otherlibs/win32unix/getpeername.c
index 9aeb4c21b09e37886f031d2f58e139f6c22d5c5d..8517f54672d31385a54939062713c53aabf85149 100644 (file)
--- a/otherlibs/win32unix/getpeername.c
+++ b/otherlibs/win32unix/getpeername.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/getpid.c b/otherlibs/win32unix/getpid.c
index 0892f8f95c7b571248ead8c75aae8c3958606ce4..677acdc55f5beef60c71c4bf3e083bbd284c4c96 100644 (file)
--- a/otherlibs/win32unix/getpid.c
+++ b/otherlibs/win32unix/getpid.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/getsockname.c b/otherlibs/win32unix/getsockname.c
index 88487a43bdf48c2e8895ff9d85a6d40f9a98801d..3af6c3412b3864d704b81e701b1b36ed01e4b949 100644 (file)
--- a/otherlibs/win32unix/getsockname.c
+++ b/otherlibs/win32unix/getsockname.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c
index f1313f06179e5f40c40caa7baff5241671dfd63d..b68eeb1ad21db4f75154fed4b6e09b680ed874b4 100644 (file)
--- a/otherlibs/win32unix/gettimeofday.c
+++ b/otherlibs/win32unix/gettimeofday.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/link.c b/otherlibs/win32unix/link.c
index 8921434234d2aa62e505b1d42e847fbfbc594bc3..05320491ed35552fa665dacbce9aa1a9f487cba4 100644 (file)
--- a/otherlibs/win32unix/link.c
+++ b/otherlibs/win32unix/link.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*                 File contributed by Lionel Fourquaux                */
 /*                                                                     */

diff --git a/otherlibs/win32unix/listen.c b/otherlibs/win32unix/listen.c
index 20789e1a4c7ae85a3d9a4a675a33c3652f5fb21e..402247fd0935ae9214b1469b3ac5feea90b4cc50 100644 (file)
--- a/otherlibs/win32unix/listen.c
+++ b/otherlibs/win32unix/listen.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c
index 524f9516b63af076a23246ad3fd92e8f2b273399..1a47824dcb16389f70a2460ccd2f584fc2544376 100644 (file)
--- a/otherlibs/win32unix/lockf.c
+++ b/otherlibs/win32unix/lockf.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com>   */
 /*  Further improvements by Reed Wilson                                */

diff --git a/otherlibs/win32unix/lseek.c b/otherlibs/win32unix/lseek.c
index 9619fcc92aa9dc37dc33f418f4d8b0d15847bc3c..86ea537dca65687a4d8206ef26ef67f584e0d88f 100644 (file)
--- a/otherlibs/win32unix/lseek.c
+++ b/otherlibs/win32unix/lseek.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/mkdir.c b/otherlibs/win32unix/mkdir.c
index aae54783bc3ac73b13eb143c7edbe98518204ac0..d47d7a28bfd71298dcbdee5eb386683b0d9feb26 100644 (file)
--- a/otherlibs/win32unix/mkdir.c
+++ b/otherlibs/win32unix/mkdir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/nonblock.c b/otherlibs/win32unix/nonblock.c
index 1bf80bfc7ebb6a72259c36eeb130eaef3f794867..1f2550b05898ea46ea0b4e47dcca49e4868b5581 100755 (executable)
--- a/otherlibs/win32unix/nonblock.c
+++ b/otherlibs/win32unix/nonblock.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -26,7 +26,7 @@ CAMLprim value unix_set_nonblock(socket)
     win32_maperr(WSAGetLastError());
     uerror("unix_set_nonblock", Nothing);
   }
-  Flags_fd_val(socket) = Flags_fd_val(socket) | FLAGS_FD_IS_BLOCKING;
+  Flags_fd_val(socket) = Flags_fd_val(socket) & ~FLAGS_FD_IS_BLOCKING;
   return Val_unit;
 }
 
@@ -39,6 +39,6 @@ CAMLprim value unix_clear_nonblock(socket)
     win32_maperr(WSAGetLastError());
     uerror("unix_clear_nonblock", Nothing);
   }
-  Flags_fd_val(socket) = Flags_fd_val(socket) & ~FLAGS_FD_IS_BLOCKING;
+  Flags_fd_val(socket) = Flags_fd_val(socket) | FLAGS_FD_IS_BLOCKING;
   return Val_unit;
 }

diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c
index f2f334bbb48000e65679f4c96d4d3f1f606cff37..74fe8fc924e6d5670373639059ac3803e55cd4cd 100644 (file)
--- a/otherlibs/win32unix/open.c
+++ b/otherlibs/win32unix/open.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
@@ -18,22 +18,27 @@
 #include "unixsupport.h"
 #include <fcntl.h>
 
-static int open_access_flags[12] = {
+static int open_access_flags[13] = {
   GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
-  0, 0, 0, 0, 0, 0, 0, 0, 0
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0
 };
 
-static int open_create_flags[12] = {
-  0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0
+static int open_create_flags[13] = {
+  0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0
+};
+
+static int open_share_flags[13] = {
+  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE
 };
 
 CAMLprim value unix_open(value path, value flags, value perm)
 {
-  int fileaccess, createflags, fileattrib, filecreate;
+  int fileaccess, createflags, fileattrib, filecreate, sharemode;
   SECURITY_ATTRIBUTES attr;
   HANDLE h;
 
   fileaccess = convert_flag_list(flags, open_access_flags);
+  sharemode = FILE_SHARE_READ | FILE_SHARE_WRITE | convert_flag_list(flags, open_share_flags);
 
   createflags = convert_flag_list(flags, open_create_flags);
   if ((createflags & (O_CREAT | O_EXCL)) == (O_CREAT | O_EXCL))
@@ -57,7 +62,7 @@ CAMLprim value unix_open(value path, value flags, value perm)
   attr.bInheritHandle = TRUE;
 
   h = CreateFile(String_val(path), fileaccess,
-                 FILE_SHARE_READ | FILE_SHARE_WRITE, &attr,
+                 sharemode, &attr,
                  filecreate, fileattrib, NULL);
   if (h == INVALID_HANDLE_VALUE) {
     win32_maperr(GetLastError());

diff --git a/otherlibs/win32unix/pipe.c b/otherlibs/win32unix/pipe.c
index afacd3e17e26031599fdc328cc427726842e1526..ca0df36996bb36fd83ddd85331d682f992f5b030 100644 (file)
--- a/otherlibs/win32unix/pipe.c
+++ b/otherlibs/win32unix/pipe.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c
index 67882eb77a094f494109e2585814b2e0c630dd00..c885857bf86b8782e19e57c32d9b8719c405cadb 100644 (file)
--- a/otherlibs/win32unix/read.c
+++ b/otherlibs/win32unix/read.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c
index 9ab43fca8951febc1314175afbd26e043e7f7427..6b750eba3e789e756a12d7c37ceaa2dcc40331c1 100644 (file)
--- a/otherlibs/win32unix/rename.c
+++ b/otherlibs/win32unix/rename.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com>   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c
index b82c423cc598f032cb66a4ab3c0114c9c0d430d6..7069d140fbcf6d91ff225567233a3b5f48e4984a 100644 (file)
--- a/otherlibs/win32unix/select.c
+++ b/otherlibs/win32unix/select.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
@@ -114,9 +114,9 @@ typedef enum _SELECTHANDLETYPE {
 
 typedef enum _SELECTMODE {
   SELECT_MODE_NONE = 0,
-  SELECT_MODE_READ,
-  SELECT_MODE_WRITE, 
-  SELECT_MODE_EXCEPT,
+  SELECT_MODE_READ = 1,
+  SELECT_MODE_WRITE = 2, 
+  SELECT_MODE_EXCEPT = 4,
 } SELECTMODE;
 
 typedef enum _SELECTSTATE {
@@ -157,7 +157,9 @@ typedef SELECTQUERY *LPSELECTQUERY;
 typedef struct _SELECTDATA {
   LIST             lst;
   SELECTTYPE       EType;
-  SELECTRESULT     aResults[MAXIMUM_SELECT_OBJECTS];
+  /* Sockets may generate a result for all three lists from one single query object
+   */
+  SELECTRESULT     aResults[MAXIMUM_SELECT_OBJECTS * 3];
   DWORD            nResultsCount;
   /* Data following are dedicated to APC like call, they
      will be initialized if required.
@@ -240,7 +242,7 @@ DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, int l
   DWORD i;
 
   res = 0;
-  if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS)
+  if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS * 3)
   {
     i = lpSelectData->nResultsCount;
     lpSelectData->aResults[i].EMode  = EMode;
@@ -490,31 +492,38 @@ LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData,
 void socket_poll (HANDLE hStop, void *_data)
 {
   LPSELECTDATA   lpSelectData;
-  LPSELECTQUERY  iterQuery;
-  HANDLE         aEvents[MAXIMUM_SELECT_OBJECTS];
-  DWORD          nEvents;
-  long           maskEvents;
-  DWORD          i;
-  u_long         iMode;
+  LPSELECTQUERY    iterQuery;
+  HANDLE           aEvents[MAXIMUM_SELECT_OBJECTS];
+  DWORD            nEvents;
+  long             maskEvents;
+  DWORD            i;
+  u_long           iMode;
+  SELECTMODE       mode;
+  WSANETWORKEVENTS events;
 
   lpSelectData = (LPSELECTDATA)_data;
 
+  DEBUG_PRINT("Worker has %d queries to service", lpSelectData->nQueriesCount);
   for (nEvents = 0; nEvents < lpSelectData->nQueriesCount; nEvents++)
   {
     iterQuery = &(lpSelectData->aQueries[nEvents]);
     aEvents[nEvents] = CreateEvent(NULL, TRUE, FALSE, NULL);
     maskEvents = 0;
-    switch (iterQuery->EMode)
+    mode = iterQuery->EMode;
+    if ((mode & SELECT_MODE_READ) != 0)
     {
-      case SELECT_MODE_READ:
-        maskEvents = FD_READ | FD_ACCEPT | FD_CLOSE;
-        break;
-      case SELECT_MODE_WRITE:
-        maskEvents = FD_WRITE | FD_CONNECT | FD_CLOSE;
-        break;
-      case SELECT_MODE_EXCEPT:
-        maskEvents = FD_OOB;
-        break;
+      DEBUG_PRINT("Polling read for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_READ | FD_ACCEPT | FD_CLOSE;
+    }
+    if ((mode & SELECT_MODE_WRITE) != 0)
+    {
+      DEBUG_PRINT("Polling write for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_WRITE | FD_CONNECT | FD_CLOSE;
+    }
+    if ((mode & SELECT_MODE_EXCEPT) != 0)
+    {
+      DEBUG_PRINT("Polling exceptions for %d", iterQuery->hFileDescr);
+      maskEvents |= FD_OOB;
     }
 
     check_error(lpSelectData,
@@ -548,7 +557,23 @@ void socket_poll (HANDLE hStop, void *_data)
         DEBUG_PRINT("Socket %d has pending events", (i - 1));
         if (iterQuery != NULL)
         {
-          select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrigIdx);
+          /* Find out what kind of events were raised
+           */
+          if (WSAEnumNetworkEvents((SOCKET)(iterQuery->hFileDescr), aEvents[i], &events) == 0)
+          {
+            if ((iterQuery->EMode & SELECT_MODE_READ) != 0 && (events.lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_READ, iterQuery->lpOrigIdx);
+            }
+            if ((iterQuery->EMode & SELECT_MODE_WRITE) != 0 && (events.lNetworkEvents & (FD_WRITE | FD_CONNECT | FD_CLOSE)) != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_WRITE, iterQuery->lpOrigIdx);
+            }
+            if ((iterQuery->EMode & SELECT_MODE_EXCEPT) != 0 && (events.lNetworkEvents & FD_OOB) != 0)
+            {
+              select_data_result_add(lpSelectData, SELECT_MODE_EXCEPT, iterQuery->lpOrigIdx);
+            }
+          }
         }
       }
       /* WSAEventSelect() automatically sets socket to nonblocking mode.
@@ -556,7 +581,7 @@ void socket_poll (HANDLE hStop, void *_data)
       if (iterQuery->uFlagsFd & FLAGS_FD_IS_BLOCKING)
       {
         DEBUG_PRINT("Restore a blocking socket");
-        iMode = 1;
+        iMode = 0;
         check_error(lpSelectData,
           WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0 ||
           ioctlsocket((SOCKET)(iterQuery->hFileDescr), FIONBIO, &iMode) != 0);
@@ -581,23 +606,88 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData,
                               unsigned int uFlagsFd)
 {
   LPSELECTDATA res;
-  LPSELECTDATA hd;
+  LPSELECTDATA candidate;
+  DWORD i;
+  LPSELECTQUERY aQueries;
   
-  hd = lpSelectData;
+  res = lpSelectData;
+  candidate = NULL;
+  aQueries = NULL;
+
   /* Polling socket can be done mulitple handle at the same time. You just
      need one worker to use it. Try to find if there is already a worker
      handling this kind of request.
+     Only one event can be associated with a given socket which means that if a socket
+     is in more than one of the fd_sets then we have to find that particular query and update
+     EMode with the additional flag.
      */
   DEBUG_PRINT("Scanning list of worker to find one that already handle socket");
-  res = select_data_job_search(&hd, SELECT_TYPE_SOCKET);
-  
-  /* Add a new socket to poll */
-  res->funcWorker = socket_poll;
-  DEBUG_PRINT("Add socket %x to worker", hFileDescr);
-  select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
-  DEBUG_PRINT("Socket %x added", hFileDescr);
+  /* Search for job */
+  DEBUG_PRINT("Searching for an available job for type %d for descriptor %d", SELECT_TYPE_SOCKET, hFileDescr);
+  while (res != NULL)
+  {
+    if (res->EType == SELECT_TYPE_SOCKET)
+    {
+      i = res->nQueriesCount - 1;
+      aQueries = res->aQueries;
+      while (i >= 0 && aQueries[i].hFileDescr != hFileDescr)
+      {
+        i--;
+      }
+      /* If we didn't find the socket but this worker has available slots, store it
+       */
+      if (i < 0)
+      {
+        if ( res->nQueriesCount < MAXIMUM_SELECT_OBJECTS)
+        {
+          candidate = res;
+        }
+        res = LIST_NEXT(LPSELECTDATA, res);
+      }
+      else
+      {
+        /* Previous socket query located -- we're finished
+         */
+        aQueries = &aQueries[i];
+        break;
+      }
+    }
+    else
+    {
+      res = LIST_NEXT(LPSELECTDATA, res);
+    }
+  }
 
-  return hd;
+  if (res == NULL)
+  {
+    res = candidate;
+
+    /* No matching job found, create one */
+    if (res == NULL)
+    {
+      DEBUG_PRINT("No job for type %d found, create one", SELECT_TYPE_SOCKET);
+      res = select_data_new(lpSelectData, SELECT_TYPE_SOCKET);
+      res->funcWorker = socket_poll;
+      res->nQueriesCount = 1;
+      aQueries = &res->aQueries[0];
+    }
+    else
+    {
+      aQueries = &(res->aQueries[res->nQueriesCount++]);
+    }
+    aQueries->EMode = EMode;
+    aQueries->hFileDescr = hFileDescr;
+    aQueries->lpOrigIdx = lpOrigIdx;
+    aQueries->uFlagsFd = uFlagsFd;
+    DEBUG_PRINT("Socket %x added", hFileDescr);
+  }
+  else
+  {
+    aQueries->EMode |= EMode;
+    DEBUG_PRINT("Socket %x updated to %d", hFileDescr, aQueries->EMode);
+  }
+
+  return res;
 }
 
 /***********************/
@@ -817,6 +907,42 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefd
 
 #define MAX(a, b) ((a) > (b) ? (a) : (b))
 
+/* Convert fdlist to an fd_set if all the handles in fdlist are sockets and return 0.
+ * Returns 1 if a non-socket value is encountered.
+ */
+static int fdlist_to_fdset(value fdlist, fd_set *fdset)
+{
+  value l, c;
+  FD_ZERO(fdset);
+  for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+    c = Field(l, 0);
+    if (Descr_kind_val(c) == KIND_SOCKET) {
+      FD_SET(Socket_val(c), fdset);
+    } else {
+      DEBUG_PRINT("Non socket value encountered");
+      return 0;
+    }
+  }
+  return 1;
+}
+
+static value fdset_to_fdlist(value fdlist, fd_set *fdset)
+{
+  value res = Val_int(0);
+  Begin_roots2(fdlist, res)
+    for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) {
+      value s = Field(fdlist, 0);
+      if (FD_ISSET(Socket_val(s), fdset)) {
+        value newres = alloc_small(2, 0);
+        Field(newres, 0) = s;
+        Field(newres, 1) = res;
+        res = newres;
+      }
+    }
+  End_roots();
+  return res;
+}
+
 CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout)
 {  
   /* Event associated to handle */
@@ -860,246 +986,287 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value
   CAMLlocal5 (read_list, write_list, except_list, res, l);
   CAMLlocal1 (fd);
 
+  fd_set read, write, except;
+  double tm;
+  struct timeval tv;
+  struct timeval * tvp;
+  
   DEBUG_PRINT("in select");
 
-  nEventsCount   = 0;
-  nEventsMax     = 0;
-  lpEventsDone   = NULL;
-  lpSelectData   = NULL;
-  iterSelectData = NULL;
-  iterResult     = NULL;
-  err            = 0;
-  hasStaticData  = 0;
-  waitRet        = 0;
-  readfds_len    = caml_list_length(readfds);
-  writefds_len   = caml_list_length(writefds);
-  exceptfds_len  = caml_list_length(exceptfds);
-  hdsMax         = MAX(readfds_len, MAX(writefds_len, exceptfds_len));
-
-  hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax);
-
-  if (Double_val(timeout) >= 0.0)
-  {
-    milliseconds = 1000 * Double_val(timeout);
-    DEBUG_PRINT("Will wait %d ms", milliseconds);
-  }
-  else
-  {
-    milliseconds = INFINITE;
-  }
-
-
-  /* Create list of select data, based on the different list of fd to watch */
-  DEBUG_PRINT("Dispatch read fd");
-  handle_set_init(&hds, hdsData, hdsMax);
-  i=0;
-  for (l = readfds; l != Val_int(0); l = Field(l, 1))
-  {
-    fd = Field(l, 0);
-    if (!handle_set_mem(&hds, Handle_val(fd)))
-    {
-      handle_set_add(&hds, Handle_val(fd));
-      lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++);
-    }
-    else
-    {
-      DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd));
-    }
-  }
-  handle_set_reset(&hds);
-
-  DEBUG_PRINT("Dispatch write fd");
-  handle_set_init(&hds, hdsData, hdsMax);
-  i=0;
-  for (l = writefds; l != Val_int(0); l = Field(l, 1))
-  {
-    fd = Field(l, 0);
-    if (!handle_set_mem(&hds, Handle_val(fd)))
-    {
-      handle_set_add(&hds, Handle_val(fd));
-      lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++);
-    }
-    else
-    {
-      DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd));
+  err = 0;
+  tm = Double_val(timeout);
+  if (readfds == Val_int(0) && writefds == Val_int(0) && exceptfds == Val_int(0)) {
+    DEBUG_PRINT("nothing to do");
+    if ( tm > 0.0 ) {
+      enter_blocking_section();
+      Sleep( (int)(tm * 1000));
+      leave_blocking_section();
     }
-  }
-  handle_set_reset(&hds);
-
-  DEBUG_PRINT("Dispatch exceptional fd");
-  handle_set_init(&hds, hdsData, hdsMax);
-  i=0;
-  for (l = exceptfds; l != Val_int(0); l = Field(l, 1))
-  {
-    fd = Field(l, 0);
-    if (!handle_set_mem(&hds, Handle_val(fd)))
-    {
-      handle_set_add(&hds, Handle_val(fd));
-      lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++);
-    }
-    else
-    {
-      DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd));
-    }
-  }
-  handle_set_reset(&hds);
-
-  /* Building the list of handle to wait for */
-  DEBUG_PRINT("Building events done array");
-  nEventsMax   = list_length((LPLIST)lpSelectData);
-  nEventsCount = 0;
-  lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax);
-
-  iterSelectData = lpSelectData;
-  while (iterSelectData != NULL)
-  {
-    /* Check if it is static data. If this is the case, launch everything
-     * but don't wait for events. It helps to test if there are events on
-     * any other fd (which are not static), knowing that there is at least
-     * one result (the static data).
-     */
-    if (iterSelectData->EType == SELECT_TYPE_STATIC)
-    {
-      hasStaticData = TRUE;
-    };
-
-    /* Execute APC */
-    if (iterSelectData->funcWorker != NULL)
-    {
-      iterSelectData->lpWorker = 
-        worker_job_submit(
-            iterSelectData->funcWorker, 
-            (void *)iterSelectData);
-      DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); 
-      lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker);
-      nEventsCount++;
-    };
-    iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
-  };
-
-  DEBUG_PRINT("Need to watch %d workers", nEventsCount);
-
-  /* Processing select itself */
-  enter_blocking_section();
-  /* There are worker started, waiting to be monitored */
-  if (nEventsCount > 0)
-  {
-    /* Waiting for event */
-    if (err == 0 && !hasStaticData)
-    {
-      DEBUG_PRINT("Waiting for one select worker to be done");
-      switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds))
-      {
-        case WAIT_FAILED:
-          err = GetLastError();
-          break;
-
-        case WAIT_TIMEOUT:
-          DEBUG_PRINT("Select timeout");
-          break;
-
-        default:
-          DEBUG_PRINT("One worker is done");
-          break;
-      };
-    }
-
-    /* Ordering stop to every worker */
-    DEBUG_PRINT("Sending stop signal to every select workers");
-    iterSelectData = lpSelectData;
-    while (iterSelectData != NULL)
-    {
-      if (iterSelectData->lpWorker != NULL)
-      {
-        worker_job_stop(iterSelectData->lpWorker);
-      };
-      iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
-    };
+    read_list = write_list = except_list = Val_int(0);
+  } else {      
+    if (fdlist_to_fdset(readfds, &read) && fdlist_to_fdset(writefds, &write) && fdlist_to_fdset(exceptfds, &except)) {
+      DEBUG_PRINT("only sockets to select on, using classic select");
+      if (tm < 0.0) {
+        tvp = (struct timeval *) NULL;
+      } else {
+        tv.tv_sec = (int) tm;
+        tv.tv_usec = (int) (1e6 * (tm - (int) tm));
+        tvp = &tv;
+      }
+      enter_blocking_section();
+      if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) {
+        err = WSAGetLastError();
+        DEBUG_PRINT("Error %ld occurred", err);
+      }
+      leave_blocking_section();
+      if (err) {
+        DEBUG_PRINT("Error %ld occurred", err);
+        win32_maperr(err);
+        uerror("select", Nothing);
+      }
+      read_list = fdset_to_fdlist(readfds, &read);
+      write_list = fdset_to_fdlist(writefds, &write);
+      except_list = fdset_to_fdlist(exceptfds, &except);
+    } else {
+      nEventsCount   = 0;
+      nEventsMax     = 0;
+      lpEventsDone   = NULL;
+      lpSelectData   = NULL;
+      iterSelectData = NULL;
+      iterResult     = NULL;
+      hasStaticData  = 0;
+      waitRet        = 0;
+      readfds_len    = caml_list_length(readfds);
+      writefds_len   = caml_list_length(writefds);
+      exceptfds_len  = caml_list_length(exceptfds);
+      hdsMax         = MAX(readfds_len, MAX(writefds_len, exceptfds_len));
       
-    DEBUG_PRINT("Waiting for every select worker to be done");
-    switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE))
-    {
-      case WAIT_FAILED:
-        err = GetLastError();
-        break;
-
-      default:
-        DEBUG_PRINT("Every worker is done");
-        break;
-    }
-  }
-  /* Nothing to monitor but some time to wait. */
-  else if (!hasStaticData)
-  {
-    Sleep(milliseconds);
-  }
-  leave_blocking_section();
-
-  DEBUG_PRINT("Error status: %d (0 is ok)", err);
-  /* Build results */
-  if (err == 0)
-  {
-    DEBUG_PRINT("Building result");
-    read_list = Val_unit; 
-    write_list = Val_unit;
-    except_list = Val_unit;
-
-    iterSelectData = lpSelectData;
-    while (iterSelectData != NULL)
-    {
-      for (i = 0; i < iterSelectData->nResultsCount; i++)
-      {
-        iterResult = &(iterSelectData->aResults[i]);
-        l = alloc_small(2, 0);
-        Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds));
-        switch (iterResult->EMode)
+      hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax);
+      
+      if (tm >= 0.0)
         {
-        case SELECT_MODE_READ:
-          Store_field(l, 1, read_list);
-          read_list = l;
-          break;
-        case SELECT_MODE_WRITE:
-          Store_field(l, 1, write_list);
-          write_list = l;
-          break;
-        case SELECT_MODE_EXCEPT:
-          Store_field(l, 1, except_list);
-          except_list = l;
-          break;
+          milliseconds = 1000 * tm;
+          DEBUG_PRINT("Will wait %d ms", milliseconds);
+        }
+      else
+        {
+          milliseconds = INFINITE;
+        }
+      
+      
+      /* Create list of select data, based on the different list of fd to watch */
+      DEBUG_PRINT("Dispatch read fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = readfds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+      
+      DEBUG_PRINT("Dispatch write fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = writefds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+      
+      DEBUG_PRINT("Dispatch exceptional fd");
+      handle_set_init(&hds, hdsData, hdsMax);
+      i=0;
+      for (l = exceptfds; l != Val_int(0); l = Field(l, 1))
+        {
+          fd = Field(l, 0);
+          if (!handle_set_mem(&hds, Handle_val(fd)))
+            {
+              handle_set_add(&hds, Handle_val(fd));
+              lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++);
+            }
+          else
+            {
+              DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd));
+            }
+        }
+      handle_set_reset(&hds);
+      
+      /* Building the list of handle to wait for */
+      DEBUG_PRINT("Building events done array");
+      nEventsMax   = list_length((LPLIST)lpSelectData);
+      nEventsCount = 0;
+      lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax);
+      
+      iterSelectData = lpSelectData;
+      while (iterSelectData != NULL)
+        {
+          /* Check if it is static data. If this is the case, launch everything
+           * but don't wait for events. It helps to test if there are events on
+           * any other fd (which are not static), knowing that there is at least
+           * one result (the static data).
+           */
+          if (iterSelectData->EType == SELECT_TYPE_STATIC)
+            {
+              hasStaticData = TRUE;
+            };
+          
+          /* Execute APC */
+          if (iterSelectData->funcWorker != NULL)
+            {
+              iterSelectData->lpWorker = 
+                worker_job_submit(
+                                  iterSelectData->funcWorker, 
+                                  (void *)iterSelectData);
+              DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); 
+              lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker);
+              nEventsCount++;
+            };
+          iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+        };
+      
+      DEBUG_PRINT("Need to watch %d workers", nEventsCount);
+      
+      /* Processing select itself */
+      enter_blocking_section();
+      /* There are worker started, waiting to be monitored */
+      if (nEventsCount > 0)
+        {
+          /* Waiting for event */
+          if (err == 0 && !hasStaticData)
+            {
+              DEBUG_PRINT("Waiting for one select worker to be done");
+              switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds))
+                {
+                case WAIT_FAILED:
+                  err = GetLastError();
+                  break;
+                  
+                case WAIT_TIMEOUT:
+                  DEBUG_PRINT("Select timeout");
+                  break;
+                  
+                default:
+                  DEBUG_PRINT("One worker is done");
+                  break;
+                };
+            }
+          
+          /* Ordering stop to every worker */
+          DEBUG_PRINT("Sending stop signal to every select workers");
+          iterSelectData = lpSelectData;
+          while (iterSelectData != NULL)
+            {
+              if (iterSelectData->lpWorker != NULL)
+                {
+                  worker_job_stop(iterSelectData->lpWorker);
+                };
+              iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+            };
+          
+          DEBUG_PRINT("Waiting for every select worker to be done");
+          switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE))
+            {
+            case WAIT_FAILED:
+              err = GetLastError();
+              break;
+              
+            default:
+              DEBUG_PRINT("Every worker is done");
+              break;
+            }
+        }
+      /* Nothing to monitor but some time to wait. */
+      else if (!hasStaticData)
+        {
+          Sleep(milliseconds);
+        }
+      leave_blocking_section();
+      
+      DEBUG_PRINT("Error status: %d (0 is ok)", err);
+      /* Build results */
+      if (err == 0)
+        {
+          DEBUG_PRINT("Building result");
+          read_list = Val_unit; 
+          write_list = Val_unit;
+          except_list = Val_unit;
+          
+          iterSelectData = lpSelectData;
+          while (iterSelectData != NULL)
+            {
+              for (i = 0; i < iterSelectData->nResultsCount; i++)
+                {
+                  iterResult = &(iterSelectData->aResults[i]);
+                  l = alloc_small(2, 0);
+                  Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds));
+                  switch (iterResult->EMode)
+                    {
+                    case SELECT_MODE_READ:
+                      Store_field(l, 1, read_list);
+                      read_list = l;
+                      break;
+                    case SELECT_MODE_WRITE:
+                      Store_field(l, 1, write_list);
+                      write_list = l;
+                      break;
+                    case SELECT_MODE_EXCEPT:
+                      Store_field(l, 1, except_list);
+                      except_list = l;
+                      break;
+                    }
+                }
+              /* We try to only process the first error, bypass other errors */
+              if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR)
+                {
+                  err = iterSelectData->nError;
+                }
+              iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+            }
+        }
+      
+      /* Free resources */
+      DEBUG_PRINT("Free selectdata resources");
+      iterSelectData = lpSelectData;
+      while (iterSelectData != NULL)
+        {
+          lpSelectData = iterSelectData;
+          iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+          select_data_free(lpSelectData);
+        }
+      lpSelectData = NULL;
+      
+      /* Free allocated events/handle set array */
+      DEBUG_PRINT("Free local allocated resources");
+      caml_stat_free(lpEventsDone);
+      caml_stat_free(hdsData);
+      
+      DEBUG_PRINT("Raise error if required");
+      if (err != 0)
+        {
+          win32_maperr(err);
+          uerror("select", Nothing);
         }
-      }
-      /* We try to only process the first error, bypass other errors */
-      if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR)
-      {
-        err = iterSelectData->nError;
-      }
-      iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
     }
   }
 
-  /* Free resources */
-  DEBUG_PRINT("Free selectdata resources");
-  iterSelectData = lpSelectData;
-  while (iterSelectData != NULL)
-  {
-    lpSelectData = iterSelectData;
-    iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
-    select_data_free(lpSelectData);
-  }
-  lpSelectData = NULL;
-  
-  /* Free allocated events/handle set array */
-  DEBUG_PRINT("Free local allocated resources");
-  caml_stat_free(lpEventsDone);
-  caml_stat_free(hdsData);
-
-  DEBUG_PRINT("Raise error if required");
-  if (err != 0)
-  {
-    win32_maperr(err);
-    uerror("select", Nothing);
-  }
-
   DEBUG_PRINT("Build final result");
   res = alloc_small(3, 0);
   Store_field(res, 0, read_list);

diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c
index 855957bd4a59ede28a365d5bf294d756596d2c41..0ee96c3dd1ddf7ea78a96e64b2966afb8c49f3bf 100644 (file)
--- a/otherlibs/win32unix/sendrecv.c
+++ b/otherlibs/win32unix/sendrecv.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
@@ -132,9 +132,7 @@ value unix_sendto_native(value sock, value buff, value ofs, value len, value fla
   return Val_int(ret);
 }
 
-CAMLprim value unix_sendto(argv, argc)
-     value * argv;
-     int argc;
+CAMLprim value unix_sendto(value * argv, int argc)
 {
   return unix_sendto_native
            (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);

diff --git a/otherlibs/win32unix/shutdown.c b/otherlibs/win32unix/shutdown.c
index f3d2c6e03f61feea03cef97d1834b9bbc149c163..dd4e7ed3465885b0965bfec87c7266c5755e4630 100644 (file)
--- a/otherlibs/win32unix/shutdown.c
+++ b/otherlibs/win32unix/shutdown.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c
index 421e5f902337783a0b6bee5f8fb3fbc90bdc8f28..682096728ab6769004abf1ce3f1805d228fd7018 100644 (file)
--- a/otherlibs/win32unix/sleep.c
+++ b/otherlibs/win32unix/sleep.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c
index 3cd55ec29fc7f7c931de46c0f00a192d67220f30..dc7a157c0b331f37242004cfb9b76887b3261efc 100644 (file)
--- a/otherlibs/win32unix/socket.c
+++ b/otherlibs/win32unix/socket.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */
@@ -17,7 +17,7 @@
 #include "unixsupport.h"
 
 int socket_domain_table[] = {
-  PF_UNIX, PF_INET
+  PF_UNIX, PF_INET /*, PF_INET6 */
 };
 
 int socket_type_table[] = {
@@ -28,25 +28,16 @@ CAMLprim value unix_socket(domain, type, proto)
      value domain, type, proto;
 {
   SOCKET s;
-  int oldvalue, oldvaluelen, newvalue, retcode;
 
-  oldvaluelen = sizeof(oldvalue);
-  retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-                       (char *) &oldvalue, &oldvaluelen);
-  if (retcode == 0) {
-    /* Set sockets to synchronous mode */
-    newvalue = SO_SYNCHRONOUS_NONALERT;
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *) &newvalue, sizeof(newvalue));
+  /* IPv6 requires WinSock2, we must raise an error on PF_INET6 */
+  if (Int_val(domain) >= sizeof(socket_domain_table)/sizeof(int)) {
+    win32_maperr(WSAEPFNOSUPPORT);
+    uerror("socket", Nothing);
   }
+
   s = socket(socket_domain_table[Int_val(domain)],
                    socket_type_table[Int_val(type)],
                    Int_val(proto));
-  if (retcode == 0) {
-    /* Restore initial mode */
-    setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
-               (char *) &oldvalue, oldvaluelen);
-  }
   if (s == INVALID_SOCKET) {
     win32_maperr(WSAGetLastError());
     uerror("socket", Nothing);

diff --git a/otherlibs/win32unix/socketaddr.h b/otherlibs/win32unix/socketaddr.h
index 8abc63b47783c2bc9ae4762cf0bee602609660ff..3d2c66754483b4fec778d60c7693fa6fd80784d5 100644 (file)
--- a/otherlibs/win32unix/socketaddr.h
+++ b/otherlibs/win32unix/socketaddr.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c
index f82d810e6e9fb8d18dfe622fd2b1904eb3d9686b..94a6c04023f71e935c7aa250e5b2d0c42bc26833 100644 (file)
--- a/otherlibs/win32unix/sockopt.c
+++ b/otherlibs/win32unix/sockopt.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c
index 8417e13669ad674f93e978ac0573f42a286d3e12..8d4def6cbada8e34a26f7f33da5a6c9dabaa3add 100644 (file)
--- a/otherlibs/win32unix/startup.c
+++ b/otherlibs/win32unix/startup.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c
index 79fc3b2eb7d2b3ba213a06fb40f3d482e90dd12d..08ad397ca1c3e1e47dea6cc6692cacf676c0bdf3 100644 (file)
--- a/otherlibs/win32unix/stat.c
+++ b/otherlibs/win32unix/stat.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c
index 51dc9bfb7bec426d9628101ef146f8338e5eb9f8..8abfa6f88c9cc24ba866351c3ec1f7daed14717e 100644 (file)
--- a/otherlibs/win32unix/system.c
+++ b/otherlibs/win32unix/system.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c
new file mode 100644 (file)
index 0000000..725895e
--- /dev/null
+++ b/otherlibs/win32unix/times.c
@@ -0,0 +1,35 @@
+#include <windows.h>\r
+#include <mlvalues.h>\r
+#include "unixsupport.h"\r
+\r
+\r
+double to_sec(FILETIME ft) {\r
+  ULARGE_INTEGER tmp;\r
+\r
+  tmp.u.LowPart = ft.dwLowDateTime;\r
+  tmp.u.HighPart = ft.dwHighDateTime;\r
+\r
+  /* convert to seconds:\r
+     GetProcessTimes returns number of 100-nanosecond intervals */\r
+  return tmp.QuadPart / 1e7;\r
+}\r
+\r
+\r
+value unix_times(value unit) {\r
+\r
+  value res;\r
+  FILETIME creation, exit, stime, utime;\r
+\r
+  if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime, &utime))) {\r
+    win32_maperr(GetLastError());\r
+    uerror("times", Nothing);\r
+  }\r
+\r
+  res = alloc_small(4 * Double_wosize, Double_array_tag);\r
+  Store_double_field(res, 0, to_sec(utime));\r
+  Store_double_field(res, 1, to_sec(stime));\r
+  Store_double_field(res, 2, 0);\r
+  Store_double_field(res, 3, 0);\r
+  return res;\r
+\r
+}\r

diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index c8396d7fd4e16e58939585d0e228753f104def9d..19c278240fe4f3e098c60c7ad9e4a16ceee48511 100644 (file)
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -170,6 +170,7 @@ type open_flag =
   | O_DSYNC
   | O_SYNC
   | O_RSYNC
+  | O_SHARE_DELETE
 
 type file_perm = int
 
@@ -407,9 +408,7 @@ external localtime : float -> tm = "unix_localtime"
 external mktime : tm -> float * tm = "unix_mktime"
 let alarm n = invalid_arg "Unix.alarm not implemented"
 external sleep : int -> unit = "unix_sleep"
-let times () =
-  { tms_utime = Sys.time(); tms_stime = 0.0;
-    tms_cutime = 0.0; tms_cstime = 0.0 }
+external times: unit -> process_times = "unix_times"
 external utimes : string -> float -> float -> unit = "unix_utimes"
 
 type interval_timer =

diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c
index 2f545c19f3d64bf6d0f218b1484efb1e2e9aa52a..f6431955bf4aa3187de427166739432ed0de8d59 100644 (file)
--- a/otherlibs/win32unix/unixsupport.c
+++ b/otherlibs/win32unix/unixsupport.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -44,7 +44,8 @@ static struct custom_operations win_handle_ops = {
   win_handle_compare,
   win_handle_hash,
   custom_serialize_default,
-  custom_deserialize_default
+  custom_deserialize_default,
+  custom_compare_ext_default
 };
 
 value win_alloc_handle(HANDLE h)
@@ -53,7 +54,7 @@ value win_alloc_handle(HANDLE h)
   Handle_val(res) = h;
   Descr_kind_val(res) = KIND_HANDLE;
   CRT_fd_val(res) = NO_CRT_FD;
-  Flags_fd_val(res) = 0;
+  Flags_fd_val(res) = FLAGS_FD_IS_BLOCKING;
   return res;
 }
 
@@ -63,7 +64,7 @@ value win_alloc_socket(SOCKET s)
   Socket_val(res) = s;
   Descr_kind_val(res) = KIND_SOCKET;
   CRT_fd_val(res) = NO_CRT_FD;
-  Flags_fd_val(res) = 0;
+  Flags_fd_val(res) = FLAGS_FD_IS_BLOCKING;
   return res;
 }
 

diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h
index d56158304d833518aa27c18a86f7f7703bf9e652..f50d40c093771055d17f8b6c67307af2ca7201f1 100644 (file)
--- a/otherlibs/win32unix/unixsupport.h
+++ b/otherlibs/win32unix/unixsupport.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Xavier Leroy and Pascal Cuoq, projet Cristal, INRIA Rocquencourt   */
 /*                                                                     */

diff --git a/otherlibs/win32unix/windbug.c b/otherlibs/win32unix/windbug.c
index e3a2772dbfcbbdaaaeaf4135c40facedc1a4786b..0370d2de7def436903bfe574bb9503fa8d0c85f1 100644 (file)
--- a/otherlibs/win32unix/windbug.c
+++ b/otherlibs/win32unix/windbug.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */

diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h
index 69cbd3b6e9d842e31247cf1ed6608ad5f17af78f..efaeffc011865ea9095897eccb710bd63912e5ee 100644 (file)
--- a/otherlibs/win32unix/windbug.h
+++ b/otherlibs/win32unix/windbug.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */
@@ -18,13 +18,15 @@
 #include <stdio.h>
 #include <windows.h>
 
+/* According to MSDN, MSVC supports the gcc ## operator (to deal with empty argument lists)
+ */
 #define DEBUG_PRINT(fmt, ...) \
   do \
   { \
     if (debug_test()) \
     { \
-      fprintf(stderr, "DBUG (pid:%d, tid: %d): ", GetCurrentProcessId(), GetCurrentThreadId()); \
-      fprintf(stderr, fmt, __VA_ARGS__); \
+      fprintf(stderr, "DBUG (pid:%ld, tid: %ld): ", GetCurrentProcessId(), GetCurrentThreadId()); \
+      fprintf(stderr, fmt, ##__VA_ARGS__); \
       fprintf(stderr, "\n"); \
       fflush(stderr); \
     }; \

diff --git a/otherlibs/win32unix/windir.c b/otherlibs/win32unix/windir.c
index 8b96589ec9398a29e78b6b29897a3abfaccc16fc..240b863b2b62dc845057dcb7fcc11c52a06bb23c 100644 (file)
--- a/otherlibs/win32unix/windir.c
+++ b/otherlibs/win32unix/windir.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*   Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA Rocquencourt  */
 /*                                                                     */

diff --git a/otherlibs/win32unix/winlist.c b/otherlibs/win32unix/winlist.c
index 318a0addfd253d1edba4b5c54016f684c8ba528b..bbb2e7cffaaebaa268a7e99855123426c3346d66 100644 (file)
--- a/otherlibs/win32unix/winlist.c
+++ b/otherlibs/win32unix/winlist.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */

diff --git a/otherlibs/win32unix/winlist.h b/otherlibs/win32unix/winlist.h
index be388a4ca2b57193288f3f26efb7aff5227f7daa..1f0a8435ab249aa081a11578285100e6bd7af805 100644 (file)
--- a/otherlibs/win32unix/winlist.h
+++ b/otherlibs/win32unix/winlist.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */

diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c
index 895a6926b81647bc754fdeee7e7382945f13d302..db13231ae22e849a228605c5861c7a9c9faf1f9f 100644 (file)
--- a/otherlibs/win32unix/winwait.c
+++ b/otherlibs/win32unix/winwait.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*   Pascal Cuoq and Xavier Leroy, projet Cristal, INRIA Rocquencourt  */
 /*                                                                     */

diff --git a/otherlibs/win32unix/winworker.c b/otherlibs/win32unix/winworker.c
index 57f95a9ae600970dd7906fae880bf0118dbd15ed..01c7dc4002b0039b174a196fd4ea9e06b521bcbd 100644 (file)
--- a/otherlibs/win32unix/winworker.c
+++ b/otherlibs/win32unix/winworker.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */

diff --git a/otherlibs/win32unix/winworker.h b/otherlibs/win32unix/winworker.h
index 06450a4ec3c8b30a618dc478a2f2cc0c2c324123..caf9067a61becbc8a7bccc03c1aa94efb900104d 100644 (file)
--- a/otherlibs/win32unix/winworker.h
+++ b/otherlibs/win32unix/winworker.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*  Contributed by Sylvain Le Gall for Lexifi                          */
 /*                                                                     */

diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c
index 190d9025394c1b285cd097eb14ca6cfb55482d7d..46d75ccba98cbe2384d563a55233de2c7374cd86 100644 (file)
--- a/otherlibs/win32unix/write.c
+++ b/otherlibs/win32unix/write.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/parsing/.cvsignore b/parsing/.cvsignore
deleted file mode 100644 (file)
index 5602bf8..0000000
--- a/parsing/.cvsignore
+++ /dev/null
@@ -1,9 +0,0 @@
-parser.ml
-parser.mli
-lexer.ml
-lexer_tmp.mll
-lexer_tmp.ml
-linenum.ml
-parser.output
-parser.automaton
-parser.conflicts

diff --git a/parsing/.ignore b/parsing/.ignore
new file mode 100644 (file)
index 0000000..5602bf8
--- /dev/null
+++ b/parsing/.ignore
@@ -0,0 +1,9 @@
+parser.ml
+parser.mli
+lexer.ml
+lexer_tmp.mll
+lexer_tmp.ml
+linenum.ml
+parser.output
+parser.automaton
+parser.conflicts

diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli
index 2530b44c6a8ca7b0ae6912a04987edda50dbcc01..d23a87fb7b7e13c5a485d6bdb74a0794dcf20a02 100644 (file)
--- a/parsing/asttypes.mli
+++ b/parsing/asttypes.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 3ddb5dde7ca59d1bf6b783d3c9ddccb3869e273a..175eedc900a3366109ba8749a9bef32323a8e9eb 100644 (file)
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 5da264ec09c07363f3ae0785e8d2a97cd0ac9532..87e2a8cbce8447d7f209698ea52e0e51407635d1 100644 (file)
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -416,7 +416,7 @@ and comment = parse
   | "*)"
       { match !comment_start_loc with
         | [] -> assert false
-        | [x] -> comment_start_loc := [];
+        | [_] -> comment_start_loc := [];
         | _ :: l -> comment_start_loc := l;
                     comment lexbuf;
        }

diff --git a/parsing/linenum.mli b/parsing/linenum.mli
deleted file mode 100644 (file)
index 50cc57e..0000000
--- a/parsing/linenum.mli
+++ /dev/null
@@ -1,23 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* An auxiliary lexer for determining the line number corresponding to
-   a file position, honoring the directives # linenum "filename" *)
-
-val for_position: string -> int -> string * int * int
-        (* [Linenum.for_position file loc] returns a triple describing
-           the location [loc] in the file named [file].
-           First result is name of actual source file.
-           Second result is line number in that source file.
-           Third result is position of beginning of that line in [file]. *)

diff --git a/parsing/linenum.mll b/parsing/linenum.mll
deleted file mode 100644 (file)
index 91e71e9..0000000
--- a/parsing/linenum.mll
+++ /dev/null
@@ -1,74 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
-(*                                                                     *)
-(*  Copyright 1997 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* An auxiliary lexer for determining the line number corresponding to
-   a file position, honoring the directives # linenum "filename" *)
-
-{
-let filename = ref ""
-let linenum = ref 0
-let linebeg = ref 0
-
-let parse_sharp_line s =
-  try
-    (* Update the line number and file name *)
-    let l1 = ref 0 in
-    while let c = s.[!l1] in c < '0' || c > '9' do incr l1 done;
-    let l2 = ref (!l1 + 1) in
-    while let c = s.[!l2] in c >= '0' && c <= '9' do incr l2 done;
-    linenum := int_of_string(String.sub s !l1 (!l2 - !l1));
-    let f1 = ref (!l2 + 1) in
-    while !f1 < String.length s && s.[!f1] <> '"' do incr f1 done;
-    let f2 = ref (!f1 + 1) in
-    while !f2 < String.length s && s.[!f2] <> '"' do incr f2 done;
-    if !f1 < String.length s then
-      filename := String.sub s (!f1 + 1) (!f2 - !f1 - 1)
-  with Failure _ | Invalid_argument _ ->
-    Misc.fatal_error "Linenum.parse_sharp_line"
-}
-
-rule skip_line = parse
-    "#" [' ' '\t']* ['0'-'9']+ [' ' '\t']*
-    ("\"" [^ '\n' '\r' '"' (* '"' *) ] * "\"")?
-    [^ '\n' '\r'] *
-    ('\n' | '\r' | "\r\n")
-      { parse_sharp_line(Lexing.lexeme lexbuf);
-        linebeg := Lexing.lexeme_start lexbuf;
-        Lexing.lexeme_end lexbuf }
-  | [^ '\n' '\r'] *
-    ('\n' | '\r' | "\r\n")
-      { incr linenum;
-        linebeg := Lexing.lexeme_start lexbuf;
-        Lexing.lexeme_end lexbuf }
-  | [^ '\n' '\r'] * eof
-      { incr linenum;
-        linebeg := Lexing.lexeme_start lexbuf;
-        raise End_of_file }
-
-{
-
-let for_position file loc =
-  let ic = open_in_bin file in
-  let lb = Lexing.from_channel ic in
-  filename := file;
-  linenum := 1;
-  linebeg := 0;
-  begin try
-    while skip_line lb <= loc do () done
-  with End_of_file -> ()
-  end;
-  close_in ic;
-  (!filename, !linenum - 1, !linebeg)
-
-}

diff --git a/parsing/location.ml b/parsing/location.ml
index 15b074acd470f306103088efc4c7ccd0a93962e0..561a9060c48d6bddd99e7d00a44eeb40919974da 100644 (file)
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -14,9 +14,11 @@
 
 open Lexing
 
-type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
+let absname = ref false
+    (* This reference should be in Clflags, but it would create an additional
+       dependency and make bootstrapping Camlp4 more difficult. *)
 
-let none = { loc_start = dummy_pos; loc_end = dummy_pos; loc_ghost = true };;
+type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
 
 let in_file name =
   let loc = {
@@ -28,6 +30,8 @@ let in_file name =
   { loc_start = loc; loc_end = loc; loc_ghost = true }
 ;;
 
+let none = in_file "_none_";;
+
 let curr lexbuf = {
   loc_start = lexbuf.lex_start_p;
   loc_end = lexbuf.lex_curr_p;
@@ -196,42 +200,57 @@ let rec highlight_locations ppf loc1 loc2 =
 
 open Format
 
+let absolute_path s = (* This function could go into Filename *)
+  let open Filename in
+  let s = if is_relative s then concat (Sys.getcwd ()) s else s in
+  (* Now simplify . and .. components *)
+  let rec aux s =
+    let base = basename s in
+    let dir = dirname s in
+    if dir = s then dir
+    else if base = current_dir_name then aux dir
+    else if base = parent_dir_name then dirname (aux dir)
+    else concat (aux dir) base
+  in
+  aux s
+
+let show_filename file =
+  if !absname then absolute_path file else file
+
+let print_filename ppf file =
+  Format.fprintf ppf "%s" (show_filename file)
+
 let reset () =
   num_loc_lines := 0
 
-let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) =
-  ("File \"", "\", line ", ", characters ", "-", ":", "")
+let (msg_file, msg_line, msg_chars, msg_to, msg_colon) =
+  ("File \"", "\", line ", ", characters ", "-", ":")
 
 (* return file, line, char from the given position *)
 let get_pos_info pos =
-  let (filename, linenum, linebeg) =
-    if pos.pos_fname = "" && !input_name = "" then
-      ("", -1, 0)
-    else if pos.pos_fname = "" then
-      Linenum.for_position !input_name pos.pos_cnum
-    else
-      (pos.pos_fname, pos.pos_lnum, pos.pos_bol)
-  in
-  (filename, linenum, pos.pos_cnum - linebeg)
+  (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
 ;;
 
-let print ppf loc =
+let print_loc ppf loc =
   let (file, line, startchar) = get_pos_info loc.loc_start in
   let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
-  let (startchar, endchar) =
-    if startchar < 0 then (0, 1) else (startchar, endchar)
-  in
-  if file = "" then begin
+  if file = "//toplevel//" then begin
     if highlight_locations ppf loc none then () else
-      fprintf ppf "Characters %i-%i:@."
+      fprintf ppf "Characters %i-%i"
               loc.loc_start.pos_cnum loc.loc_end.pos_cnum
   end else begin
-    fprintf ppf "%s%s%s%i" msg_file file msg_line line;
-    fprintf ppf "%s%i" msg_chars startchar;
-    fprintf ppf "%s%i%s@.%s" msg_to endchar msg_colon msg_head;
+    fprintf ppf "%s%a%s%i" msg_file print_filename file msg_line line;
+    if startchar >= 0 then
+      fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar
   end
 ;;
 
+let print ppf loc =
+  if loc.loc_start.pos_fname = "//toplevel//"
+  && highlight_locations ppf loc none then ()
+  else fprintf ppf "%a%s@." print_loc loc msg_colon
+;;
+
 let print_error ppf loc =
   print ppf loc;
   fprintf ppf "Error: ";
@@ -245,7 +264,7 @@ let print_warning loc ppf w =
       let n = Warnings.print ppf w in
       num_loc_lines := !num_loc_lines + n
     in
-    fprintf ppf "%a" print loc;
+    print ppf loc;
     fprintf ppf "Warning %a@." printw w;
     pp_print_flush ppf ();
     incr num_loc_lines;

diff --git a/parsing/location.mli b/parsing/location.mli
index a496a35506a1102d4dc3d49cb07e5c00ebb9f923..2b1a5a8fa5a67253931a051534f451a8a0aeca2c 100644 (file)
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -46,7 +46,8 @@ val rhs_loc: int -> t
 val input_name: string ref
 val input_lexbuf: Lexing.lexbuf option ref
 
-val get_pos_info : Lexing.position -> string * int * int (* file, line, char *)
+val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
+val print_loc: formatter -> t -> unit
 val print_error: formatter -> t -> unit
 val print_error_cur_file: formatter -> unit
 val print_warning: t -> formatter -> Warnings.t -> unit
@@ -55,3 +56,13 @@ val echo_eof: unit -> unit
 val reset: unit -> unit
 
 val highlight_locations: formatter -> t -> t -> bool
+
+val print: formatter -> t -> unit
+val print_filename: formatter -> string -> unit
+
+val show_filename: string -> string
+    (** In -absname mode, return the absolute path for this filename.
+        Otherwise, returns the filename unchanged. *)
+
+
+val absname: bool ref

diff --git a/parsing/longident.ml b/parsing/longident.ml
index 1b459ca3f4d2db2672c1767fd0c995cb757ed6f1..612f9df197301683724b2674919eb3f75f426465 100644 (file)
--- a/parsing/longident.ml
+++ b/parsing/longident.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,14 +20,14 @@ type t =
 let rec flat accu = function
     Lident s -> s :: accu
   | Ldot(lid, s) -> flat (s :: accu) lid
-  | Lapply(l1, l2) -> Misc.fatal_error "Longident.flat"
+  | Lapply(_, _) -> Misc.fatal_error "Longident.flat"
 
 let flatten lid = flat [] lid
 
 let last = function
     Lident s -> s
-  | Ldot(lid, s) -> s
-  | Lapply(l1, l2) -> Misc.fatal_error "Longident.last"
+  | Ldot(_, s) -> s
+  | Lapply(_, _) -> Misc.fatal_error "Longident.last"
 
 let rec split_at_dots s pos =
   try

diff --git a/parsing/longident.mli b/parsing/longident.mli
index 4568bc953cdbb87e4ad9475239636fd027defe5e..a802049b96109c1d119051c4b272af77950954d6 100644 (file)
--- a/parsing/longident.mli
+++ b/parsing/longident.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/parsing/parse.ml b/parsing/parse.ml
index 7f3e4cdc02e55dd24ebdd848915355c8d7991bb6..cf862af3f1668ee03f7bd58281935cdf25a5a65d 100644 (file)
--- a/parsing/parse.ml
+++ b/parsing/parse.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -46,14 +46,14 @@ let wrap parsing_fun lexbuf =
   | Lexer.Error(Lexer.Unterminated_string, _) as err -> raise err
   | Lexer.Error(Lexer.Unterminated_string_in_comment, _) as err -> raise err
   | Lexer.Error(Lexer.Illegal_character _, _) as err ->
-      if !Location.input_name = "" then skip_phrase lexbuf;
+      if !Location.input_name = "//toplevel//" then skip_phrase lexbuf;
       raise err
   | Syntaxerr.Error _ as err ->
-      if !Location.input_name = "" then maybe_skip_phrase lexbuf;
+      if !Location.input_name = "//toplevel//" then maybe_skip_phrase lexbuf;
       raise err
   | Parsing.Parse_error | Syntaxerr.Escape_error ->
       let loc = Location.curr lexbuf in
-      if !Location.input_name = ""
+      if !Location.input_name = "//toplevel//"
       then maybe_skip_phrase lexbuf;
       raise(Syntaxerr.Error(Syntaxerr.Other loc))
 ;;

diff --git a/parsing/parse.mli b/parsing/parse.mli
index 87a09f0e2a84fa8362146da565f465f8d53968ab..85e08bc48231fa2a47a608cfd9877aa890934e26 100644 (file)
--- a/parsing/parse.mli
+++ b/parsing/parse.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 9311b34cc713a0527adb341815fcc8f6b3121f9d..a5065b5cfd105e9279a624814b74ca067a1bf78e 100644 (file)
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -47,9 +47,12 @@ let reloc_exp x = { x with pexp_loc = symbol_rloc () };;
 let mkoperator name pos =
   { pexp_desc = Pexp_ident(Lident name); pexp_loc = rhs_loc pos }
 
+let mkpatvar name pos =
+  { ppat_desc = Ppat_var name; ppat_loc = rhs_loc pos }
+
 (*
   Ghost expressions and patterns:
-  expressions and patterns that do not appear explicitely in the
+  expressions and patterns that do not appear explicitly in the
   source file they have the loc_ghost flag set to true.
   Then the profiler will not try to instrument them and the
   -stypes option will not try to display their type.
@@ -70,8 +73,9 @@ let ghtyp d = { ptyp_desc = d; ptyp_loc = symbol_gloc () };;
 
 let mkassert e =
   match e with
-  | {pexp_desc = Pexp_construct (Lident "false", None, false) } ->
-         mkexp (Pexp_assertfalse)
+  | { pexp_desc = Pexp_construct (Lident "false", None, false);
+      pexp_loc = _ } ->
+      mkexp (Pexp_assertfalse)
   | _ -> mkexp (Pexp_assert (e))
 ;;
 
@@ -160,7 +164,7 @@ let bigarray_function str name =
   Ldot(Ldot(Lident "Bigarray", str), name)
 
 let bigarray_untuplify = function
-    { pexp_desc = Pexp_tuple explist} -> explist
+    { pexp_desc = Pexp_tuple explist; pexp_loc = _ } -> explist
   | exp -> [exp]
 
 let bigarray_get arr arg =
@@ -208,6 +212,68 @@ let exp_of_label lbl =
 let pat_of_label lbl =
   mkpat (Ppat_var(Longident.last lbl))
 
+let check_variable vl loc v =
+  if List.mem v vl then
+    raise Syntaxerr.(Error(Variable_in_scope(loc,v)))
+
+let varify_constructors var_names t =
+  let rec loop t =
+    let desc =
+      match t.ptyp_desc with
+      | Ptyp_any -> Ptyp_any
+      | Ptyp_var x ->
+          check_variable var_names t.ptyp_loc x;
+          Ptyp_var x
+      | Ptyp_arrow (label,core_type,core_type') ->
+          Ptyp_arrow(label, loop core_type, loop core_type')
+      | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)
+      | Ptyp_constr(Lident s, []) when List.mem s var_names ->
+          Ptyp_var s
+      | Ptyp_constr(longident, lst) ->
+          Ptyp_constr(longident, List.map loop lst)
+      | Ptyp_object lst ->
+          Ptyp_object (List.map loop_core_field lst)
+      | Ptyp_class (longident, lst, lbl_list) ->
+          Ptyp_class (longident, List.map loop lst, lbl_list)
+      | Ptyp_alias(core_type, string) ->
+          check_variable var_names t.ptyp_loc string;
+          Ptyp_alias(loop core_type, string)
+      | Ptyp_variant(row_field_list, flag, lbl_lst_option) ->
+          Ptyp_variant(List.map loop_row_field row_field_list,
+                       flag, lbl_lst_option)
+      | Ptyp_poly(string_lst, core_type) ->
+          List.iter (check_variable var_names t.ptyp_loc) string_lst;
+          Ptyp_poly(string_lst, loop core_type)
+      | Ptyp_package(longident,lst) ->
+          Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)
+    in
+    {t with ptyp_desc = desc}
+  and loop_core_field t =
+    let desc =
+      match t.pfield_desc with
+      | Pfield(n,typ) ->
+          Pfield(n,loop typ)
+      | Pfield_var ->
+          Pfield_var
+    in
+    { t with pfield_desc=desc}
+  and loop_row_field  =
+    function
+      | Rtag(label,flag,lst) ->
+          Rtag(label,flag,List.map loop lst)
+      | Rinherit t ->
+          Rinherit (loop t)
+  in
+  loop t
+
+let wrap_type_annotation newtypes core_type body =
+  let exp = mkexp(Pexp_constraint(body,Some core_type,None)) in
+  let exp =
+    List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp)))
+      newtypes exp
+  in
+  (exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type)))
+
 %}
 
 /* Tokens */
@@ -453,10 +519,24 @@ module_expr:
       { $2 }
   | LPAREN module_expr error
       { unclosed "(" 1 ")" 3 }
+  | LPAREN VAL expr RPAREN
+      { mkmod(Pmod_unpack $3) }
   | LPAREN VAL expr COLON package_type RPAREN
-      { mkmod(Pmod_unpack($3, $5)) }
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)), None)))) }
+  | LPAREN VAL expr COLON package_type COLONGREATER package_type RPAREN
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, Some(ghtyp(Ptyp_package $5)),
+                                    Some(ghtyp(Ptyp_package $7)))))) }
+  | LPAREN VAL expr COLONGREATER package_type RPAREN
+      { mkmod(Pmod_unpack(
+              ghexp(Pexp_constraint($3, None, Some(ghtyp(Ptyp_package $5)))))) }
   | LPAREN VAL expr COLON error
       { unclosed "(" 1 ")" 5 }
+  | LPAREN VAL expr COLONGREATER error
+      { unclosed "(" 1 ")" 5 }
+  | LPAREN VAL expr error
+      { unclosed "(" 1 ")" 4 }
 ;
 structure:
     structure_tail                              { $1 }
@@ -472,7 +552,7 @@ structure_tail:
 structure_item:
     LET rec_flag let_bindings
       { match $3 with
-          [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp)
+          [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp)
         | _ -> mkstr(Pstr_value($2, List.rev $3)) }
   | EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
       { mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) }
@@ -702,6 +782,10 @@ concrete_method :
       { $4, $3, $2, ghexp(Pexp_poly ($5, None)), symbol_rloc () }
   | METHOD override_flag private_flag label COLON poly_type EQUAL seq_expr
       { $4, $3, $2, ghexp(Pexp_poly($8,Some $6)), symbol_rloc () }
+  | METHOD override_flag private_flag label COLON TYPE lident_list
+    DOT core_type EQUAL seq_expr
+      { let exp, poly = wrap_type_annotation $7 $9 $11 in
+        $4, $3, $2, ghexp(Pexp_poly(exp, Some poly)), symbol_rloc () }
 ;
 
 /* Class types */
@@ -1021,8 +1105,11 @@ simple_expr:
       { mkexp(Pexp_override []) }
   | simple_expr SHARP label
       { mkexp(Pexp_send($1, $3)) }
+  | LPAREN MODULE module_expr RPAREN
+      { mkexp (Pexp_pack $3) }
   | LPAREN MODULE module_expr COLON package_type RPAREN
-      { mkexp (Pexp_pack ($3, $5)) }
+      { mkexp (Pexp_constraint (ghexp (Pexp_pack $3),
+                                Some (ghtyp (Ptyp_package $5)), None)) }
   | LPAREN MODULE module_expr COLON error
       { unclosed "(" 1 ")" 5 }
 ;
@@ -1055,13 +1142,19 @@ let_bindings:
     let_binding                                 { [$1] }
   | let_bindings AND let_binding                { $3 :: $1 }
 ;
+
+lident_list:
+    LIDENT                            { [$1] }
+  | LIDENT lident_list                { $1 :: $2 }
+;
 let_binding:
     val_ident fun_binding
-      { ({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1}, $2) }
+      { (mkpatvar $1 1, $2) }
   | val_ident COLON typevar_list DOT core_type EQUAL seq_expr
-      { (ghpat(Ppat_constraint({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1},
-                               ghtyp(Ptyp_poly($3,$5)))),
-         $7) }
+      { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7) }
+  | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
+      { let exp, poly = wrap_type_annotation $4 $6 $8 in
+        (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
   | pattern EQUAL seq_expr
       { ($1, $3) }
 ;
@@ -1191,6 +1284,12 @@ simple_pattern:
       { mkpat(Ppat_constraint($2, $4)) }
   | LPAREN pattern COLON core_type error
       { unclosed "(" 1 ")" 5 }
+  | LPAREN MODULE UIDENT RPAREN
+      { mkpat(Ppat_unpack $3) }
+  | LPAREN MODULE UIDENT COLON package_type RPAREN
+      { mkpat(Ppat_constraint(mkpat(Ppat_unpack $3),ghtyp(Ptyp_package $5))) }
+  | LPAREN MODULE UIDENT COLON package_type error
+      { unclosed "(" 1 ")" 6 }
 ;
 
 pattern_comma_list:
@@ -1227,7 +1326,7 @@ type_declarations:
 ;
 
 type_declaration:
-    type_parameters LIDENT type_kind constraints
+    optional_type_parameters LIDENT type_kind constraints
       { let (params, variance) = List.split $1 in
         let (kind, private_flag, manifest) = $3 in
         ($2, {ptype_params = params;
@@ -1236,7 +1335,7 @@ type_declaration:
               ptype_private = private_flag;
               ptype_manifest = manifest;
               ptype_variance = variance;
-              ptype_loc = symbol_rloc()}) }
+              ptype_loc = symbol_rloc() }) }
 ;
 constraints:
         constraints CONSTRAINT constrain        { $3 :: $1 }
@@ -1262,6 +1361,22 @@ type_kind:
   | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE
       { (Ptype_record(List.rev $6), $4, Some $2) }
 ;
+optional_type_parameters:
+    /*empty*/                                   { [] }
+  | optional_type_parameter                              { [$1] }
+  | LPAREN optional_type_parameter_list RPAREN  { List.rev $2 }
+;
+optional_type_parameter:
+    type_variance QUOTE ident                   { Some $3, $1 }
+  | type_variance UNDERSCORE                    { None, $1 }
+;
+optional_type_parameter_list:
+    optional_type_parameter                              { [$1] }
+  | optional_type_parameter_list COMMA optional_type_parameter    { $3 :: $1 }
+;
+
+
+
 type_parameters:
     /*empty*/                                   { [] }
   | type_parameter                              { [$1] }
@@ -1284,12 +1399,27 @@ constructor_declarations:
   | constructor_declarations BAR constructor_declaration { $3 :: $1 }
 ;
 constructor_declaration:
-    constr_ident constructor_arguments          { ($1, $2, symbol_rloc()) }
+
+  | constr_ident generalized_constructor_arguments
+      { let arg_types,ret_type = $2 in
+        ($1, arg_types,ret_type, symbol_rloc()) }
 ;
+
 constructor_arguments:
     /*empty*/                                   { [] }
   | OF core_type_list                           { List.rev $2 }
 ;
+
+generalized_constructor_arguments:
+    /*empty*/                                   { ([],None) }
+  | OF core_type_list                           { (List.rev $2,None) }
+  | COLON core_type_list MINUSGREATER simple_core_type
+                                                { (List.rev $2,Some $4) }
+  | COLON simple_core_type                      { ([],Some $2) }
+;
+
+
+
 label_declarations:
     label_declaration                           { [$1] }
   | label_declarations SEMI label_declaration   { $3 :: $1 }
@@ -1307,7 +1437,7 @@ with_constraints:
 with_constraint:
     TYPE type_parameters label_longident with_type_binder core_type constraints
       { let params, variance = List.split $2 in
-        ($3, Pwith_type {ptype_params = params;
+        ($3, Pwith_type {ptype_params = List.map (fun x -> Some x) params;
                          ptype_cstrs = List.rev $6;
                          ptype_kind = Ptype_abstract;
                          ptype_manifest = Some $5;
@@ -1318,7 +1448,7 @@ with_constraint:
        functor applications in type path */
   | TYPE type_parameters label_longident COLONEQUAL core_type
       { let params, variance = List.split $2 in
-        ($3, Pwith_typesubst {ptype_params = params;
+        ($3, Pwith_typesubst {ptype_params = List.map (fun x -> Some x) params;
                               ptype_cstrs = [];
                               ptype_kind = Ptype_abstract;
                               ptype_manifest = Some $5;
@@ -1426,7 +1556,7 @@ package_type:
   | mty_longident WITH package_type_cstrs { ($1, $3) }
 ;
 package_type_cstr:
-    TYPE LIDENT EQUAL core_type { ($2, $4) }
+    TYPE label_longident EQUAL core_type { ($2, $4) }
 ;
 package_type_cstrs:
     package_type_cstr { [$1] }

diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 05f92bd03782a68ca397d2aca2c036c616179f13..663ae7c55b5ac0f30776353625ace44e127038c0 100644 (file)
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -35,7 +35,7 @@ and core_type_desc =
   | Ptyp_poly of string list * core_type
   | Ptyp_package of package_type
 
-and package_type = Longident.t * (string * core_type) list
+and package_type = Longident.t * (Longident.t * core_type) list
 
 and core_field_type =
   { pfield_desc: core_field_desc;
@@ -79,6 +79,7 @@ and pattern_desc =
   | Ppat_constraint of pattern * core_type
   | Ppat_type of Longident.t
   | Ppat_lazy of pattern
+  | Ppat_unpack of string
 
 type expression =
   { pexp_desc: expression_desc;
@@ -116,7 +117,7 @@ and expression_desc =
   | Pexp_poly of expression * core_type option
   | Pexp_object of class_structure
   | Pexp_newtype of string * expression
-  | Pexp_pack of module_expr * package_type
+  | Pexp_pack of module_expr
   | Pexp_open of Longident.t * expression
 
 (* Value descriptions *)
@@ -128,7 +129,7 @@ and value_description =
 (* Type declarations *)
 
 and type_declaration =
-  { ptype_params: string list;
+  { ptype_params: string option list;
     ptype_cstrs: (core_type * core_type * Location.t) list;
     ptype_kind: type_kind;
     ptype_private: private_flag;
@@ -138,7 +139,8 @@ and type_declaration =
 
 and type_kind =
     Ptype_abstract
-  | Ptype_variant of (string * core_type list * Location.t) list
+  | Ptype_variant of
+      (string * core_type list * core_type option * Location.t) list
   | Ptype_record of
       (string * mutable_flag * core_type * Location.t) list
 
@@ -187,12 +189,13 @@ and class_structure = pattern * class_field list
 and class_field =
     Pcf_inher of override_flag * class_expr * string option
   | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
-  | Pcf_val of (string * mutable_flag * override_flag * expression * Location.t)
-  | Pcf_virt  of (string * private_flag * core_type * Location.t)
-  | Pcf_meth of (string * private_flag *override_flag * expression * Location.t)
-  | Pcf_cstr  of (core_type * core_type * Location.t)
-  | Pcf_let   of rec_flag * (pattern * expression) list * Location.t
-  | Pcf_init  of expression
+  | Pcf_val of
+      (string * mutable_flag * override_flag * expression * Location.t)
+  | Pcf_virt of (string * private_flag * core_type * Location.t)
+  | Pcf_meth of
+      (string * private_flag * override_flag * expression * Location.t)
+  | Pcf_cstr of (core_type * core_type * Location.t)
+  | Pcf_init of expression
 
 and class_declaration = class_expr class_infos
 
@@ -237,7 +240,7 @@ and with_constraint =
   | Pwith_typesubst of type_declaration
   | Pwith_modsubst of Longident.t
 
-(* value expressions for the module language *)
+(* Value expressions for the module language *)
 
 and module_expr =
   { pmod_desc: module_expr_desc;
@@ -249,7 +252,7 @@ and module_expr_desc =
   | Pmod_functor of string * module_type * module_expr
   | Pmod_apply of module_expr * module_expr
   | Pmod_constraint of module_expr * module_type
-  | Pmod_unpack of expression * package_type
+  | Pmod_unpack of expression
 
 and structure = structure_item list
 

diff --git a/parsing/printast.ml b/parsing/printast.ml
index f63e21b879c046e40079b10e0cae0575f4500b49..d5b99331138772a258e10cf4bb69d5616500b5e2 100644 (file)
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,9 +19,7 @@ open Location;;
 open Parsetree;;
 
 let fmt_position f l =
-  if l.pos_fname = "" && l.pos_lnum = 1
-  then fprintf f "%d" l.pos_cnum
-  else if l.pos_lnum = -1
+  if l.pos_lnum = -1
   then fprintf f "%s[%d]" l.pos_fname l.pos_cnum
   else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol
                (l.pos_cnum - l.pos_bol)
@@ -98,7 +96,7 @@ let line i f s (*...*) =
 let list i f ppf l =
   match l with
   | [] -> line i ppf "[]\n";
-  | h::t ->
+  | _ :: _ ->
      line i ppf "[\n";
      List.iter (f (i+1) ppf) l;
      line i ppf "]\n";
@@ -154,10 +152,10 @@ let rec core_type i ppf x =
       core_type i ppf ct;
   | Ptyp_package (s, l) ->
       line i ppf "Ptyp_package %a\n" fmt_longident s;
-      list i package_with ppf l
+      list i package_with ppf l;
 
 and package_with i ppf (s, t) =
-  line i ppf "with type %s\n" s;
+  line i ppf "with type %a\n" fmt_longident s;
   core_type i ppf t
 
 and core_field_type i ppf x =
@@ -209,6 +207,8 @@ and pattern i ppf x =
   | Ppat_type li ->
       line i ppf "Ppat_type";
       longident i ppf li
+  | Ppat_unpack s ->
+      line i ppf "Ppat_unpack \"%s\"\n" s;
 
 and expression i ppf x =
   line i ppf "expression %a\n" fmt_location x.pexp_loc;
@@ -321,9 +321,8 @@ and expression i ppf x =
   | Pexp_newtype (s, e) ->
       line i ppf "Pexp_newtype \"%s\"\n" s;
       expression i ppf e
-  | Pexp_pack (me, (p,l)) ->
-      line i ppf "Pexp_pack %a" fmt_longident p;
-      list i package_with ppf l;
+  | Pexp_pack me ->
+      line i ppf "Pexp_pack";
       module_expr i ppf me
   | Pexp_open (m, e) ->
       line i ppf "Pexp_open \"%a\"\n" fmt_longident m;
@@ -334,11 +333,18 @@ and value_description i ppf x =
   core_type (i+1) ppf x.pval_type;
   list (i+1) string ppf x.pval_prim;
 
+and string_option_underscore i ppf = 
+  function
+    | Some x ->
+       string i ppf x
+    | None ->
+       string i ppf "_"
+
 and type_declaration i ppf x =
   line i ppf "type_declaration %a\n" fmt_location x.ptype_loc;
   let i = i+1 in
   line i ppf "ptype_params =\n";
-  list (i+1) string ppf x.ptype_params;
+  list (i+1) string_option_underscore ppf x.ptype_params;
   line i ppf "ptype_cstrs =\n";
   list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
   line i ppf "ptype_kind =\n";
@@ -483,9 +489,6 @@ and class_field i ppf x =
       line i ppf "Pcf_cstr %a\n" fmt_location loc;
       core_type (i+1) ppf ct1;
       core_type (i+1) ppf ct2;
-  | Pcf_let (rf, l, loc) ->
-      line i ppf "Pcf_let %a %a\n" fmt_rec_flag rf fmt_location loc;
-      list (i+1) pattern_x_expression_def ppf l;
   | Pcf_init (e) ->
       line i ppf "Pcf_init\n";
       expression (i+1) ppf e;
@@ -518,7 +521,7 @@ and module_type i ppf x =
       list i longident_x_with_constraint ppf l;
   | Pmty_typeof m ->
       line i ppf "Pmty_typeof\n";
-      module_expr i ppf m
+      module_expr i ppf m;
 
 and signature i ppf x = list i signature_item ppf x
 
@@ -593,9 +596,8 @@ and module_expr i ppf x =
       line i ppf "Pmod_constraint\n";
       module_expr i ppf me;
       module_type i ppf mt;
-  | Pmod_unpack (e, (p, l)) ->
-      line i ppf "Pmod_unpack %a\n" fmt_longident p;
-      list i package_with ppf l;
+  | Pmod_unpack (e) ->
+      line i ppf "Pmod_unpack\n";
       expression i ppf e;
 
 and structure i ppf x = list i structure_item ppf x
@@ -663,9 +665,10 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
   core_type (i+1) ppf ct1;
   core_type (i+1) ppf ct2;
 
-and string_x_core_type_list_x_location i ppf (s, l, loc) =
+and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) = 
   line i ppf "\"%s\" %a\n" s fmt_location loc;
   list (i+1) core_type ppf l;
+  option (i+1) core_type ppf r_opt;
 
 and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
   line i ppf "\"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;

diff --git a/parsing/printast.mli b/parsing/printast.mli
index 7ea148678db34deb1de29bff9d886dc33d52e630..096f461727099091095266073201fc983ce3e8ff 100644 (file)
--- a/parsing/printast.mli
+++ b/parsing/printast.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index edaabda122f9df8ac300ebd645837a9518d6b571..f18e3281d37ffbd75d79a9a78303e8689cce8c7c 100644 (file)
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,15 +19,17 @@ open Format
 type error =
     Unclosed of Location.t * string * Location.t * string
   | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
   | Other of Location.t
 
+
 exception Error of error
 exception Escape_error
 
 let report_error ppf = function
   | Unclosed(opening_loc, opening, closing_loc, closing) ->
-      if String.length !Location.input_name = 0
-      && Location.highlight_locations ppf opening_loc closing_loc
+      if !Location.input_name = "//toplevel//"
+         && Location.highlight_locations ppf opening_loc closing_loc
       then fprintf ppf "Syntax error: '%s' expected, \
                    the highlighted '%s' might be unmatched" closing opening
       else begin
@@ -37,7 +39,14 @@ let report_error ppf = function
           Location.print_error opening_loc opening
       end
   | Applicative_path loc ->
-      fprintf ppf "%aSyntax error: applicative paths of the form F(X).t are not supported when the option -no-app-func is set."
+      fprintf ppf
+        "%aSyntax error: applicative paths of the form F(X).t \
+         are not supported when the option -no-app-func is set."
         Location.print_error loc
+  | Variable_in_scope (loc, var) ->
+      fprintf ppf
+        "%a@[In this scoped type, variable '%s@ \
+         is reserved for the local type %s.@]"
+        Location.print_error loc var var
   | Other loc ->
       fprintf ppf "%aSyntax error" Location.print_error loc

diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index 4e9679926a3cd0bd4ec98ed3025e6b0d639e489a..c2f9eb07c5fd54a3b4e3007f1d9e943e7e6d12b3 100644 (file)
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,6 +19,7 @@ open Format
 type error =
     Unclosed of Location.t * string * Location.t * string
   | Applicative_path of Location.t
+  | Variable_in_scope of Location.t * string
   | Other of Location.t
 
 exception Error of error

diff --git a/stdlib/.cvsignore b/stdlib/.cvsignore
deleted file mode 100644 (file)
index 6aa0cd4..0000000
--- a/stdlib/.cvsignore
+++ /dev/null
@@ -1,7 +0,0 @@
-camlheader
-camlheader_ur
-labelled-*
-caml
-*.annot
-sys.ml
-*.a

diff --git a/stdlib/.depend b/stdlib/.depend
index 0267136b7102a9edc37c68d1e6f3f6b3b02b2d52..3fd2959bc4a5e7681800581d5db6e5b6f9f311d0 100644 (file)
--- a/stdlib/.depend
+++ b/stdlib/.depend
@@ -1,248 +1,260 @@
-arg.cmi:
-array.cmi:
-arrayLabels.cmi:
-buffer.cmi:
-callback.cmi:
-camlinternalLazy.cmi:
-camlinternalMod.cmi: obj.cmi
-camlinternalOO.cmi: obj.cmi
-char.cmi:
-complex.cmi:
-digest.cmi:
-filename.cmi:
-format.cmi: pervasives.cmi buffer.cmi
-gc.cmi:
-genlex.cmi: stream.cmi
-hashtbl.cmi:
-int32.cmi:
-int64.cmi:
-lazy.cmi:
-lexing.cmi:
-list.cmi:
-listLabels.cmi:
-map.cmi:
-marshal.cmi:
-moreLabels.cmi: set.cmi map.cmi hashtbl.cmi
-nativeint.cmi:
-obj.cmi: int32.cmi
-oo.cmi: camlinternalOO.cmi
-parsing.cmi: obj.cmi lexing.cmi
-pervasives.cmi:
-printexc.cmi:
-printf.cmi: obj.cmi buffer.cmi
-queue.cmi:
-random.cmi: nativeint.cmi int64.cmi int32.cmi
-scanf.cmi: pervasives.cmi
-set.cmi:
-sort.cmi:
-stack.cmi:
-stdLabels.cmi:
-stream.cmi:
-string.cmi:
-stringLabels.cmi:
-sys.cmi:
-weak.cmi: hashtbl.cmi
-arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi
-arg.cmx: sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx arg.cmi
-array.cmo: array.cmi
-array.cmx: array.cmi
-arrayLabels.cmo: array.cmi arrayLabels.cmi
-arrayLabels.cmx: array.cmx arrayLabels.cmi
-buffer.cmo: sys.cmi string.cmi buffer.cmi
-buffer.cmx: sys.cmx string.cmx buffer.cmi
-callback.cmo: obj.cmi callback.cmi
-callback.cmx: obj.cmx callback.cmi
-camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi
-camlinternalLazy.cmx: obj.cmx camlinternalLazy.cmi
-camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi
-camlinternalMod.cmx: obj.cmx camlinternalOO.cmx array.cmx camlinternalMod.cmi
-camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
-    array.cmi camlinternalOO.cmi
-camlinternalOO.cmx: sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
-    array.cmx camlinternalOO.cmi
-char.cmo: char.cmi
-char.cmx: char.cmi
-complex.cmo: complex.cmi
-complex.cmx: complex.cmi
-digest.cmo: string.cmi printf.cmi digest.cmi
-digest.cmx: string.cmx printf.cmx digest.cmi
-filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
+arg.cmi :
+array.cmi :
+arrayLabels.cmi :
+buffer.cmi :
+callback.cmi :
+camlinternalLazy.cmi :
+camlinternalMod.cmi : obj.cmi
+camlinternalOO.cmi : obj.cmi
+char.cmi :
+complex.cmi :
+digest.cmi :
+filename.cmi :
+format.cmi : pervasives.cmi buffer.cmi
+gc.cmi :
+genlex.cmi : stream.cmi
+hashtbl.cmi :
+int32.cmi :
+int64.cmi :
+lazy.cmi :
+lexing.cmi :
+list.cmi :
+listLabels.cmi :
+map.cmi :
+marshal.cmi :
+moreLabels.cmi : set.cmi map.cmi hashtbl.cmi
+nativeint.cmi :
+obj.cmi : int32.cmi
+oo.cmi : camlinternalOO.cmi
+parsing.cmi : obj.cmi lexing.cmi
+pervasives.cmi :
+printexc.cmi :
+printf.cmi : obj.cmi buffer.cmi
+queue.cmi :
+random.cmi : nativeint.cmi int64.cmi int32.cmi
+scanf.cmi : pervasives.cmi
+set.cmi :
+sort.cmi :
+stack.cmi :
+stdLabels.cmi :
+stream.cmi :
+string.cmi :
+stringLabels.cmi :
+sys.cmi :
+weak.cmi : hashtbl.cmi
+arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
+    arg.cmi
+arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \
+    arg.cmi
+array.cmo : array.cmi
+array.cmx : array.cmi
+arrayLabels.cmo : array.cmi arrayLabels.cmi
+arrayLabels.cmx : array.cmx arrayLabels.cmi
+buffer.cmo : sys.cmi string.cmi buffer.cmi
+buffer.cmx : sys.cmx string.cmx buffer.cmi
+callback.cmo : obj.cmi callback.cmi
+callback.cmx : obj.cmx callback.cmi
+camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
+camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi
+camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
+    camlinternalMod.cmi
+camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \
+    camlinternalMod.cmi
+camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
+    callback.cmi array.cmi camlinternalOO.cmi
+camlinternalOO.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \
+    callback.cmx array.cmx camlinternalOO.cmi
+char.cmo : char.cmi
+char.cmx : char.cmi
+complex.cmo : complex.cmi
+complex.cmx : complex.cmi
+digest.cmo : string.cmi printf.cmi char.cmi digest.cmi
+digest.cmx : string.cmx printf.cmx char.cmx digest.cmi
+filename.cmo : sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
     filename.cmi
-filename.cmx: sys.cmx string.cmx random.cmx printf.cmx buffer.cmx \
+filename.cmx : sys.cmx string.cmx random.cmx printf.cmx buffer.cmx \
     filename.cmi
-format.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi buffer.cmi \
-    format.cmi
-format.cmx: string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx buffer.cmx \
-    format.cmi
-gc.cmo: sys.cmi printf.cmi gc.cmi
-gc.cmx: sys.cmx printf.cmx gc.cmi
-genlex.cmo: string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi
-genlex.cmx: string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi
-hashtbl.cmo: sys.cmi array.cmi hashtbl.cmi
-hashtbl.cmx: sys.cmx array.cmx hashtbl.cmi
-int32.cmo: pervasives.cmi int32.cmi
-int32.cmx: pervasives.cmx int32.cmi
-int64.cmo: pervasives.cmi int64.cmi
-int64.cmx: pervasives.cmx int64.cmi
-lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi
-lazy.cmx: obj.cmx camlinternalLazy.cmx lazy.cmi
-lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi
-lexing.cmx: sys.cmx string.cmx array.cmx lexing.cmi
-list.cmo: list.cmi
-list.cmx: list.cmi
-listLabels.cmo: list.cmi listLabels.cmi
-listLabels.cmx: list.cmx listLabels.cmi
-map.cmo: map.cmi
-map.cmx: map.cmi
-marshal.cmo: string.cmi marshal.cmi
-marshal.cmx: string.cmx marshal.cmi
-moreLabels.cmo: set.cmi map.cmi hashtbl.cmi moreLabels.cmi
-moreLabels.cmx: set.cmx map.cmx hashtbl.cmx moreLabels.cmi
-nativeint.cmo: sys.cmi pervasives.cmi nativeint.cmi
-nativeint.cmx: sys.cmx pervasives.cmx nativeint.cmi
-obj.cmo: marshal.cmi int32.cmi array.cmi obj.cmi
-obj.cmx: marshal.cmx int32.cmx array.cmx obj.cmi
-oo.cmo: camlinternalOO.cmi oo.cmi
-oo.cmx: camlinternalOO.cmx oo.cmi
-parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi
-parsing.cmx: obj.cmx lexing.cmx array.cmx parsing.cmi
-pervasives.cmo: pervasives.cmi
-pervasives.cmx: pervasives.cmi
-printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
-printexc.cmx: printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi
-printf.cmo: string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
+format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \
+    buffer.cmi format.cmi
+format.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \
+    buffer.cmx format.cmi
+gc.cmo : sys.cmi printf.cmi gc.cmi
+gc.cmx : sys.cmx printf.cmx gc.cmi
+genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi
+genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi
+hashtbl.cmo : sys.cmi obj.cmi array.cmi hashtbl.cmi
+hashtbl.cmx : sys.cmx obj.cmx array.cmx hashtbl.cmi
+int32.cmo : pervasives.cmi int32.cmi
+int32.cmx : pervasives.cmx int32.cmi
+int64.cmo : pervasives.cmi int64.cmi
+int64.cmx : pervasives.cmx int64.cmi
+lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
+lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi
+lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi
+lexing.cmx : sys.cmx string.cmx array.cmx lexing.cmi
+list.cmo : list.cmi
+list.cmx : list.cmi
+listLabels.cmo : list.cmi listLabels.cmi
+listLabels.cmx : list.cmx listLabels.cmi
+map.cmo : map.cmi
+map.cmx : map.cmi
+marshal.cmo : string.cmi marshal.cmi
+marshal.cmx : string.cmx marshal.cmi
+moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
+moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi
+nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
+nativeint.cmx : sys.cmx pervasives.cmx nativeint.cmi
+obj.cmo : marshal.cmi int32.cmi array.cmi obj.cmi
+obj.cmx : marshal.cmx int32.cmx array.cmx obj.cmi
+oo.cmo : camlinternalOO.cmi oo.cmi
+oo.cmx : camlinternalOO.cmx oo.cmi
+parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
+parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi
+pervasives.cmo : pervasives.cmi
+pervasives.cmx : pervasives.cmi
+printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
+printexc.cmx : printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi
+printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
     array.cmi printf.cmi
-printf.cmx: string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \
+printf.cmx : string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \
     array.cmx printf.cmi
-queue.cmo: obj.cmi queue.cmi
-queue.cmx: obj.cmx queue.cmi
-random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
+queue.cmo : obj.cmi queue.cmi
+queue.cmx : obj.cmx queue.cmi
+random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
     digest.cmi char.cmi array.cmi random.cmi
-random.cmx: string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
+random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \
     digest.cmx char.cmx array.cmx random.cmi
-scanf.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi hashtbl.cmi \
-    buffer.cmi array.cmi scanf.cmi
-scanf.cmx: string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx hashtbl.cmx \
-    buffer.cmx array.cmx scanf.cmi
-set.cmo: set.cmi
-set.cmx: set.cmi
-sort.cmo: array.cmi sort.cmi
-sort.cmx: array.cmx sort.cmi
-stack.cmo: list.cmi stack.cmi
-stack.cmx: list.cmx stack.cmi
-stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi
-stdLabels.cmx: stringLabels.cmx listLabels.cmx arrayLabels.cmx stdLabels.cmi
-std_exit.cmo:
-std_exit.cmx:
-stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi
-stream.cmx: string.cmx obj.cmx list.cmx lazy.cmx stream.cmi
-string.cmo: pervasives.cmi list.cmi char.cmi string.cmi
-string.cmx: pervasives.cmx list.cmx char.cmx string.cmi
-stringLabels.cmo: string.cmi stringLabels.cmi
-stringLabels.cmx: string.cmx stringLabels.cmi
-sys.cmo: sys.cmi
-sys.cmx: sys.cmi
-weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
-weak.cmx: sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
-arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi
-arg.p.cmx: sys.p.cmx string.p.cmx printf.p.cmx list.p.cmx buffer.p.cmx array.p.cmx arg.cmi
-array.cmo: array.cmi
-array.p.cmx: array.cmi
-arrayLabels.cmo: array.cmi arrayLabels.cmi
-arrayLabels.p.cmx: array.p.cmx arrayLabels.cmi
-buffer.cmo: sys.cmi string.cmi buffer.cmi
-buffer.p.cmx: sys.p.cmx string.p.cmx buffer.cmi
-callback.cmo: obj.cmi callback.cmi
-callback.p.cmx: obj.p.cmx callback.cmi
-camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi
-camlinternalLazy.p.cmx: obj.p.cmx camlinternalLazy.cmi
-camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi
-camlinternalMod.p.cmx: obj.p.cmx camlinternalOO.p.cmx array.p.cmx camlinternalMod.cmi
-camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
-    array.cmi camlinternalOO.cmi
-camlinternalOO.p.cmx: sys.p.cmx string.p.cmx obj.p.cmx map.p.cmx list.p.cmx char.p.cmx \
-    array.p.cmx camlinternalOO.cmi
-char.cmo: char.cmi
-char.p.cmx: char.cmi
-complex.cmo: complex.cmi
-complex.p.cmx: complex.cmi
-digest.cmo: string.cmi printf.cmi digest.cmi
-digest.p.cmx: string.p.cmx printf.p.cmx digest.cmi
-filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
+scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \
+    hashtbl.cmi buffer.cmi array.cmi scanf.cmi
+scanf.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \
+    hashtbl.cmx buffer.cmx array.cmx scanf.cmi
+set.cmo : set.cmi
+set.cmx : set.cmi
+sort.cmo : array.cmi sort.cmi
+sort.cmx : array.cmx sort.cmi
+stack.cmo : list.cmi stack.cmi
+stack.cmx : list.cmx stack.cmi
+stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \
+    stdLabels.cmi
+stdLabels.cmx : stringLabels.cmx listLabels.cmx arrayLabels.cmx \
+    stdLabels.cmi
+std_exit.cmo :
+std_exit.cmx :
+stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi
+stream.cmx : string.cmx obj.cmx list.cmx lazy.cmx stream.cmi
+string.cmo : pervasives.cmi list.cmi char.cmi string.cmi
+string.cmx : pervasives.cmx list.cmx char.cmx string.cmi
+stringLabels.cmo : string.cmi stringLabels.cmi
+stringLabels.cmx : string.cmx stringLabels.cmi
+sys.cmo : sys.cmi
+sys.cmx : sys.cmi
+weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
+weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi
+arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \
+    arg.cmi
+arg.p.cmx : sys.p.cmx string.p.cmx printf.p.cmx list.p.cmx buffer.p.cmx array.p.cmx \
+    arg.cmi
+array.cmo : array.cmi
+array.p.cmx : array.cmi
+arrayLabels.cmo : array.cmi arrayLabels.cmi
+arrayLabels.p.cmx : array.p.cmx arrayLabels.cmi
+buffer.cmo : sys.cmi string.cmi buffer.cmi
+buffer.p.cmx : sys.p.cmx string.p.cmx buffer.cmi
+callback.cmo : obj.cmi callback.cmi
+callback.p.cmx : obj.p.cmx callback.cmi
+camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
+camlinternalLazy.p.cmx : obj.p.cmx camlinternalLazy.cmi
+camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
+    camlinternalMod.cmi
+camlinternalMod.p.cmx : obj.p.cmx camlinternalOO.p.cmx array.p.cmx \
+    camlinternalMod.cmi
+camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \
+    callback.cmi array.cmi camlinternalOO.cmi
+camlinternalOO.p.cmx : sys.p.cmx string.p.cmx obj.p.cmx map.p.cmx list.p.cmx char.p.cmx \
+    callback.p.cmx array.p.cmx camlinternalOO.cmi
+char.cmo : char.cmi
+char.p.cmx : char.cmi
+complex.cmo : complex.cmi
+complex.p.cmx : complex.cmi
+digest.cmo : string.cmi printf.cmi char.cmi digest.cmi
+digest.p.cmx : string.p.cmx printf.p.cmx char.p.cmx digest.cmi
+filename.cmo : sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \
     filename.cmi
-filename.p.cmx: sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx buffer.p.cmx \
+filename.p.cmx : sys.p.cmx string.p.cmx random.p.cmx printf.p.cmx buffer.p.cmx \
     filename.cmi
-format.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi buffer.cmi \
-    format.cmi
-format.p.cmx: string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx buffer.p.cmx \
-    format.cmi
-gc.cmo: sys.cmi printf.cmi gc.cmi
-gc.p.cmx: sys.p.cmx printf.p.cmx gc.cmi
-genlex.cmo: string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi
-genlex.p.cmx: string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi
-hashtbl.cmo: sys.cmi array.cmi hashtbl.cmi
-hashtbl.p.cmx: sys.p.cmx array.p.cmx hashtbl.cmi
-int32.cmo: pervasives.cmi int32.cmi
-int32.p.cmx: pervasives.p.cmx int32.cmi
-int64.cmo: pervasives.cmi int64.cmi
-int64.p.cmx: pervasives.p.cmx int64.cmi
-lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi
-lazy.p.cmx: obj.p.cmx camlinternalLazy.p.cmx lazy.cmi
-lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi
-lexing.p.cmx: sys.p.cmx string.p.cmx array.p.cmx lexing.cmi
-list.cmo: list.cmi
-list.p.cmx: list.cmi
-listLabels.cmo: list.cmi listLabels.cmi
-listLabels.p.cmx: list.p.cmx listLabels.cmi
-map.cmo: map.cmi
-map.p.cmx: map.cmi
-marshal.cmo: string.cmi marshal.cmi
-marshal.p.cmx: string.p.cmx marshal.cmi
-moreLabels.cmo: set.cmi map.cmi hashtbl.cmi moreLabels.cmi
-moreLabels.p.cmx: set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi
-nativeint.cmo: sys.cmi pervasives.cmi nativeint.cmi
-nativeint.p.cmx: sys.p.cmx pervasives.p.cmx nativeint.cmi
-obj.cmo: marshal.cmi int32.cmi array.cmi obj.cmi
-obj.p.cmx: marshal.p.cmx int32.p.cmx array.p.cmx obj.cmi
-oo.cmo: camlinternalOO.cmi oo.cmi
-oo.p.cmx: camlinternalOO.p.cmx oo.cmi
-parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi
-parsing.p.cmx: obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi
-pervasives.cmo: pervasives.cmi
-pervasives.p.cmx: pervasives.cmi
-printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
-printexc.p.cmx: printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi
-printf.cmo: string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
+format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \
+    buffer.cmi format.cmi
+format.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \
+    buffer.p.cmx format.cmi
+gc.cmo : sys.cmi printf.cmi gc.cmi
+gc.p.cmx : sys.p.cmx printf.p.cmx gc.cmi
+genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi
+genlex.p.cmx : string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi
+hashtbl.cmo : sys.cmi obj.cmi array.cmi hashtbl.cmi
+hashtbl.p.cmx : sys.p.cmx obj.p.cmx array.p.cmx hashtbl.cmi
+int32.cmo : pervasives.cmi int32.cmi
+int32.p.cmx : pervasives.p.cmx int32.cmi
+int64.cmo : pervasives.cmi int64.cmi
+int64.p.cmx : pervasives.p.cmx int64.cmi
+lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi
+lazy.p.cmx : obj.p.cmx camlinternalLazy.p.cmx lazy.cmi
+lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi
+lexing.p.cmx : sys.p.cmx string.p.cmx array.p.cmx lexing.cmi
+list.cmo : list.cmi
+list.p.cmx : list.cmi
+listLabels.cmo : list.cmi listLabels.cmi
+listLabels.p.cmx : list.p.cmx listLabels.cmi
+map.cmo : map.cmi
+map.p.cmx : map.cmi
+marshal.cmo : string.cmi marshal.cmi
+marshal.p.cmx : string.p.cmx marshal.cmi
+moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi
+moreLabels.p.cmx : set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi
+nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi
+nativeint.p.cmx : sys.p.cmx pervasives.p.cmx nativeint.cmi
+obj.cmo : marshal.cmi int32.cmi array.cmi obj.cmi
+obj.p.cmx : marshal.p.cmx int32.p.cmx array.p.cmx obj.cmi
+oo.cmo : camlinternalOO.cmi oo.cmi
+oo.p.cmx : camlinternalOO.p.cmx oo.cmi
+parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi
+parsing.p.cmx : obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi
+pervasives.cmo : pervasives.cmi
+pervasives.p.cmx : pervasives.cmi
+printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi
+printexc.p.cmx : printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi
+printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \
     array.cmi printf.cmi
-printf.p.cmx: string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \
+printf.p.cmx : string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \
     array.p.cmx printf.cmi
-queue.cmo: obj.cmi queue.cmi
-queue.p.cmx: obj.p.cmx queue.cmi
-random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
+queue.cmo : obj.cmi queue.cmi
+queue.p.cmx : obj.p.cmx queue.cmi
+random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \
     digest.cmi char.cmi array.cmi random.cmi
-random.p.cmx: string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \
+random.p.cmx : string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \
     digest.p.cmx char.p.cmx array.p.cmx random.cmi
-scanf.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi hashtbl.cmi \
-    buffer.cmi array.cmi scanf.cmi
-scanf.p.cmx: string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx hashtbl.p.cmx \
-    buffer.p.cmx array.p.cmx scanf.cmi
-set.cmo: set.cmi
-set.p.cmx: set.cmi
-sort.cmo: array.cmi sort.cmi
-sort.p.cmx: array.p.cmx sort.cmi
-stack.cmo: list.cmi stack.cmi
-stack.p.cmx: list.p.cmx stack.cmi
-stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi
-stdLabels.p.cmx: stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx stdLabels.cmi
-std_exit.cmo:
-std_exit.p.cmx:
-stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi
-stream.p.cmx: string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi
-string.cmo: pervasives.cmi list.cmi char.cmi string.cmi
-string.p.cmx: pervasives.p.cmx list.p.cmx char.p.cmx string.cmi
-stringLabels.cmo: string.cmi stringLabels.cmi
-stringLabels.p.cmx: string.p.cmx stringLabels.cmi
-sys.cmo: sys.cmi
-sys.p.cmx: sys.cmi
-weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
-weak.p.cmx: sys.p.cmx obj.p.cmx hashtbl.p.cmx array.p.cmx weak.cmi
+scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \
+    hashtbl.cmi buffer.cmi array.cmi scanf.cmi
+scanf.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \
+    hashtbl.p.cmx buffer.p.cmx array.p.cmx scanf.cmi
+set.cmo : set.cmi
+set.p.cmx : set.cmi
+sort.cmo : array.cmi sort.cmi
+sort.p.cmx : array.p.cmx sort.cmi
+stack.cmo : list.cmi stack.cmi
+stack.p.cmx : list.p.cmx stack.cmi
+stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \
+    stdLabels.cmi
+stdLabels.p.cmx : stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx \
+    stdLabels.cmi
+std_exit.cmo :
+std_exit.p.cmx :
+stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi
+stream.p.cmx : string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi
+string.cmo : pervasives.cmi list.cmi char.cmi string.cmi
+string.p.cmx : pervasives.p.cmx list.p.cmx char.p.cmx string.cmi
+stringLabels.cmo : string.cmi stringLabels.cmi
+stringLabels.p.cmx : string.p.cmx stringLabels.cmi
+sys.cmo : sys.cmi
+sys.p.cmx : sys.cmi
+weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi
+weak.p.cmx : sys.p.cmx obj.p.cmx hashtbl.p.cmx array.p.cmx weak.cmi

diff --git a/stdlib/.ignore b/stdlib/.ignore
new file mode 100644 (file)
index 0000000..ad1b04e
--- /dev/null
+++ b/stdlib/.ignore
@@ -0,0 +1,6 @@
+camlheader
+camlheaderd
+camlheader_ur
+labelled-*
+caml
+sys.ml

diff --git a/stdlib/Compflags b/stdlib/Compflags
index 862a1c4e1ea18bfcd33501e447ff87424c8184ed..80bb1b6673bd4be30d5d96c66f36c1da9740ba99 100755 (executable)
--- a/stdlib/Compflags
+++ b/stdlib/Compflags
@@ -1,7 +1,7 @@
 #!/bin/sh
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                OCaml                                  #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -18,6 +18,7 @@ case $1 in
   pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';;
   camlinternalOO.cmi) echo ' -nopervasives';;
   camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
+  buffer.cm[io]|printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';;
   scanf.cmx|scanf.p.cmx) echo ' -inline 9';;
   arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';;
   listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';;

diff --git a/stdlib/Makefile b/stdlib/Makefile
index 874dcf6f9e625e954f9eca5bc5f4538847786113..2c8e067063f797ef6734c5e4893fd191efbea16b 100644 (file)
--- a/stdlib/Makefile
+++ b/stdlib/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -42,9 +42,10 @@ installopt-prof:
 stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx)
        $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx)
 
-camlheader camlheader_ur: header.c ../config/Makefile
+camlheader camlheaderd camlheader_ur: header.c ../config/Makefile
        if $(SHARPBANGSCRIPTS); then \
          echo '#!$(BINDIR)/ocamlrun' > camlheader && \
+         echo '#!$(BINDIR)/ocamlrund' > camlheaderd && \
          echo '#!' | tr -d '\012' > camlheader_ur; \
        else \
          $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
@@ -52,7 +53,12 @@ camlheader camlheader_ur: header.c ../config/Makefile
                    header.c -o tmpheader$(EXE) && \
          strip tmpheader$(EXE) && \
          mv tmpheader$(EXE) camlheader && \
-         cp camlheader camlheader_ur; \
+         cp camlheader camlheader_ur && \
+         $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) \
+                   -DRUNTIME_NAME='"$(BINDIR)/ocamlrund"' \
+                   header.c -o tmpheader$(EXE) && \
+         strip tmpheader$(EXE) && \
+         mv tmpheader$(EXE) camlheaderd; \
        fi
 
 .PHONY: all allopt allopt-noprof allopt-prof install installopt

diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt
index 995a0c3fd6deca51fac94ecc9055c5522179dc2f..579391a7750b4a714eb9b8fc37683c2647c75ce9 100644 (file)
--- a/stdlib/Makefile.nt
+++ b/stdlib/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -21,11 +21,18 @@ installopt:
        cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR)
 
 camlheader camlheader_ur: headernt.c ../config/Makefile
-       $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun headernt.c
+       $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+                 -DRUNTIME_NAME='"ocamlrun"' headernt.c
        $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
        rm -f camlheader.exe
        mv tmpheader.exe camlheader
        cp camlheader camlheader_ur
 
+camlheaderd: headernt.c ../config/Makefile
+       $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun \
+                 -DRUNTIME_NAME='"ocamlrund"' headernt.c
+       $(MKEXE) -o tmpheader.exe headernt.$(O) $(EXTRALIBS)
+       mv tmpheader.exe camlheaderd
+
 # TODO: do not call flexlink to build tmpheader.exe (we don't need
 # the export table)

diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared
index 64087dc9c323e765113183e7cc74470ea32f6263..0752a1b5f13ef5b9f305c5f9ded6ee70f4009898 100755 (executable)
--- a/stdlib/Makefile.shared
+++ b/stdlib/Makefile.shared
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -40,8 +40,16 @@ OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \
 
 all: stdlib.cma std_exit.cmo camlheader camlheader_ur
 
-install:
-       cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur $(LIBDIR)
+install: install-$(RUNTIMED)
+       cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \
+         $(LIBDIR)
+
+install-noruntimed:
+.PHONY: install-noruntimed
+
+install-runtimed: camlheaderd
+       cp camlheaderd $(LIBDIR)
+.PHONY: install-runtimed
 
 stdlib.cma: $(OBJS)
        $(CAMLC) -a -o stdlib.cma $(OBJS)
@@ -56,7 +64,7 @@ clean::
        rm -f sys.ml
 
 clean::
-       rm -f camlheader camlheader_ur
+       rm -f camlheader camlheader_ur camlheaderd
 
 .SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx
 

diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules
index 4f689f8c4ad813164c5c6245cdfc6871eee78cd4..926e2cb5143356293abb2335af267ea96d297005 100644 (file)
--- a/stdlib/StdlibModules
+++ b/stdlib/StdlibModules
@@ -1,7 +1,23 @@
-# This file lists all standard library modules. -*- Makefile -*-
-# It is used in particular to know what to expunge in toplevels.
+# -*- Makefile -*-
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2002 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the GNU Library General Public License, with     #
+#   the special exception on linking described in file ../LICENSE.      #
+#                                                                       #
+#########################################################################
+
 # $Id$
 
+# This file lists all standard library modules.
+# It is used in particular to know what to expunge in toplevels.
+
 STDLIB_MODULES=\
   arg \
   array \

diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index ac552d38e8abb69cea32f6bf284dd3cdd056e4e6..8453058e4e7271a4e768548605a5c185a0a2cdad 100644 (file)
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -64,10 +64,11 @@ let make_symlist prefix sep suffix l =
 ;;
 
 let print_spec buf (key, spec, doc) =
-  match spec with
-  | Symbol (l, _) -> bprintf buf "  %s %s%s\n" key (make_symlist "{" "|" "}" l)
-                             doc
-  | _ -> bprintf buf "  %s %s\n" key doc
+  if String.length doc > 0 then
+    match spec with
+    | Symbol (l, _) -> bprintf buf "  %s %s%s\n" key (make_symlist "{" "|" "}" l)
+                               doc
+    | _ -> bprintf buf "  %s %s\n" key doc
 ;;
 
 let help_action () = raise (Stop (Unknown "-help"));;
@@ -237,6 +238,10 @@ let max_arg_len cur (kwd, spec, doc) =
 
 let add_padding len ksd =
   match ksd with
+  | (_, _, "") ->
+      (* Do not pad undocumented options, so that they still don't show up when
+       * run through [usage] or [parse]. *)
+      ksd
   | (kwd, (Symbol (l, _) as spec), msg) ->
       let cutcol = second_word msg in
       let spaces = String.make (len - cutcol + 3) ' ' in

diff --git a/stdlib/arg.mli b/stdlib/arg.mli
index 8872566152276f7ab92bd67a8358cfbef5221a75..d6e0210aa133e50490d32b4000bd0581fdba8ad6 100644 (file)
--- a/stdlib/arg.mli
+++ b/stdlib/arg.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -83,6 +83,8 @@ val parse :
 -   The reason for the error: unknown option, invalid or missing argument, etc.
 -   [usage_msg]
 -   The list of options, each followed by the corresponding [doc] string.
+    Beware: options that have an empty [doc] string will not be included in the
+    list.
 
     For the user to be able to specify anonymous arguments starting with a
     [-], include for example [("-", String anon_fun, doc)] in [speclist].

diff --git a/stdlib/array.ml b/stdlib/array.ml
index d1cbd655767bea8dedcf19bffcade5cbada4b056..076a3af0310bc34d29b176949f09e84631049e9a 100644 (file)
--- a/stdlib/array.ml
+++ b/stdlib/array.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                           OCaml                                     *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -22,6 +22,10 @@ external unsafe_get: 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set: 'a array -> int -> 'a -> unit = "%array_unsafe_set"
 external make: int -> 'a -> 'a array = "caml_make_vect"
 external create: int -> 'a -> 'a array = "caml_make_vect"
+external sub : 'a array -> int -> int -> 'a array = "caml_array_sub"
+external append_prim : 'a array -> 'a array -> 'a array = "caml_array_append"
+external concat : 'a array list -> 'a array = "caml_array_concat"
+external unsafe_blit : 'a array -> int -> 'a array -> int -> int -> unit = "caml_array_blit"
 
 let init l f =
   if l = 0 then [||] else
@@ -41,58 +45,13 @@ let make_matrix sx sy init =
 let create_matrix = make_matrix
 
 let copy a =
-  let l = length a in
-  if l = 0 then [||] else begin
-    let res = create l (unsafe_get a 0) in
-    for i = 1 to pred l do
-      unsafe_set res i (unsafe_get a i)
-    done;
-    res
-  end
+  let l = length a in if l = 0 then [||] else sub a 0 l
 
 let append a1 a2 =
-  let l1 = length a1 and l2 = length a2 in
-  if l1 = 0 && l2 = 0 then [||] else begin
-    let r = create (l1 + l2) (unsafe_get (if l1 > 0 then a1 else a2) 0) in
-    for i = 0 to l1 - 1 do unsafe_set r i (unsafe_get a1 i) done;
-    for i = 0 to l2 - 1 do unsafe_set r (i + l1) (unsafe_get a2 i) done;
-    r
-  end
-
-let concat_aux init al =
-  let rec size accu = function
-    | [] -> accu
-    | h::t -> size (accu + length h) t
-  in
-  let res = create (size 0 al) init in
-  let rec fill pos = function
-    | [] -> ()
-    | h::t ->
-        for i = 0 to length h - 1 do
-          unsafe_set res (pos + i) (unsafe_get h i);
-        done;
-        fill (pos + length h) t;
-  in
-  fill 0 al;
-  res
-;;
-
-let concat al =
-  let rec find_init aa =
-    match aa with
-    | [] -> [||]
-    | a :: rem ->
-        if length a > 0 then concat_aux (unsafe_get a 0) aa else find_init rem
-  in find_init al
-
-let sub a ofs len =
-  if ofs < 0 || len < 0 || ofs > length a - len then invalid_arg "Array.sub"
-  else if len = 0 then [||]
-  else begin
-    let r = create len (unsafe_get a ofs) in
-    for i = 1 to len - 1 do unsafe_set r i (unsafe_get a (ofs + i)) done;
-    r
-  end
+  let l1 = length a1 in
+  if l1 = 0 then copy a2
+  else if length a2 = 0 then sub a1 0 l1
+  else append_prim a1 a2
 
 let fill a ofs len v =
   if ofs < 0 || len < 0 || ofs > length a - len
@@ -103,16 +62,7 @@ let blit a1 ofs1 a2 ofs2 len =
   if len < 0 || ofs1 < 0 || ofs1 > length a1 - len
              || ofs2 < 0 || ofs2 > length a2 - len
   then invalid_arg "Array.blit"
-  else if ofs1 < ofs2 then
-    (* Top-down copy *)
-    for i = len - 1 downto 0 do
-      unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
-    done
-  else
-    (* Bottom-up copy *)
-    for i = 0 to len - 1 do
-      unsafe_set a2 (ofs2 + i) (unsafe_get a1 (ofs1 + i))
-    done
+  else unsafe_blit a1 ofs1 a2 ofs2 len
 
 let iter f a =
   for i = 0 to length a - 1 do f(unsafe_get a i) done

diff --git a/stdlib/array.mli b/stdlib/array.mli
index 9fb74b06eb86132f966806c2b1555c9a18043c19..db1f469d0e78ff1de106fbf5b7cd83b28012839e 100644 (file)
--- a/stdlib/array.mli
+++ b/stdlib/array.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -201,5 +201,7 @@ val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
 (**/**)
 (** {6 Undocumented functions} *)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"

diff --git a/stdlib/arrayLabels.ml b/stdlib/arrayLabels.ml
index fed0ad1c2c4b4f22fa221b083e90a3dc379a9fac..652f4cac422975cf41e75348fab09a9b9b9ed7a1 100644 (file)
--- a/stdlib/arrayLabels.ml
+++ b/stdlib/arrayLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)

diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli
index f45f70c6dec326aa6a2fe765ff725009f18d1484..308bfa4e1cf07f602fc3b98567f6656acdeb0cd2 100644 (file)
--- a/stdlib/arrayLabels.mli
+++ b/stdlib/arrayLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -205,5 +205,7 @@ val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit
 
 (** {6 Undocumented functions} *)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
 external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"

diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml
index 9327aaefb5a7ffa86eff5d488cfa5c996f12fd62..541717ade8947dfeba8f577ee702944d8355af1a 100644 (file)
--- a/stdlib/buffer.ml
+++ b/stdlib/buffer.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*   Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt  *)
 (*                                                                     *)

diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli
index efe2e9ea2e91ac912680cd46cc47d37269153028..ce70c983e979f203453277a66b0f6f339b9f4b16 100644 (file)
--- a/stdlib/buffer.mli
+++ b/stdlib/buffer.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)

diff --git a/stdlib/callback.ml b/stdlib/callback.ml
index 819f9d3f40da4c238f4368ea19e9887b3c7629d6..5dd7894846c7ef4aa9070e3b9853c476c95eac15 100644 (file)
--- a/stdlib/callback.ml
+++ b/stdlib/callback.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -13,7 +13,7 @@
 
 (* $Id$ *)
 
-(* Registering Caml values with the C runtime for later callbacks *)
+(* Registering OCaml values with the C runtime for later callbacks *)
 
 external register_named_value : string -> Obj.t -> unit
                               = "caml_register_named_value"

diff --git a/stdlib/callback.mli b/stdlib/callback.mli
index ba2ab7ecb7e41f468690e998c49bb059ccfaf429..c536bf8d53db613309d85ba76d66990865b5750d 100644 (file)
--- a/stdlib/callback.mli
+++ b/stdlib/callback.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -13,11 +13,11 @@
 
 (* $Id$ *)
 
-(** Registering Caml values with the C runtime.
+(** Registering OCaml values with the C runtime.
 
-   This module allows Caml values to be registered with the C runtime
+   This module allows OCaml values to be registered with the C runtime
    under a symbolic name, so that C code can later call back registered
-   Caml functions, or raise registered Caml exceptions.
+   OCaml functions, or raise registered OCaml exceptions.
 *)
 
 val register : string -> 'a -> unit
@@ -30,5 +30,5 @@ val register_exception : string -> exn -> unit
    exception contained in the exception value [exn]
    under the name [n]. C code can later retrieve a handle to
    the exception by calling [caml_named_value(n)]. The exception
-   value thus obtained is suitable for passign as first argument
+   value thus obtained is suitable for passing as first argument
    to [raise_constant] or [raise_with_arg]. *)

diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml
index 46cf42788ad72c73cf8b015a5f673dfded7d7de8..042a377c9dab954b7283cdd83690c43760e96574 100644 (file)
--- a/stdlib/camlinternalLazy.ml
+++ b/stdlib/camlinternalLazy.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)

diff --git a/stdlib/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli
index 37b707d4f922f87ef98616176cec0e6e6dd10b81..eef1c9d6fd9ffea8306e8d7b2ea17988f04ddb1d 100644 (file)
--- a/stdlib/camlinternalLazy.mli
+++ b/stdlib/camlinternalLazy.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -13,7 +13,9 @@
 
 (* $Id$ *)
 
-(* Internals of forcing lazy values *)
+(** Run-time support for lazy values.
+    All functions in this module are for system use only, not for the
+    casual user. *)
 
 exception Undefined;;
 

diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml
index 12a77cc8fbead85a833b8be2fbc3becadf93709f..36d73bdcf240b396a9f9de9201bd569e3c0d9944 100644 (file)
--- a/stdlib/camlinternalMod.ml
+++ b/stdlib/camlinternalMod.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy, projet Cristal, INRIA Rocquencourt            *)
 (*                                                                     *)

diff --git a/stdlib/camlinternalMod.mli b/stdlib/camlinternalMod.mli
index 74bf28db288a204b7163e10cbcbbf9a4f00361b0..bc59f1956459ed7d0ca1d0a8d5c05942c39001b5 100644 (file)
--- a/stdlib/camlinternalMod.mli
+++ b/stdlib/camlinternalMod.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Xavier Leroy, projet Cristal, INRIA Rocquencourt            *)
 (*                                                                     *)
@@ -13,6 +13,10 @@
 
 (* $Id$ *)
 
+(** Run-time support for recursive modules.
+    All functions in this module are for system use only, not for the
+    casual user. *)
+
 type shape =
   | Function
   | Lazy

diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml
index 2ffa71c0a24b5cd03e3e6f355d4c56d71fa05d40..6d787146553667db458222f479f25c37c96b1882 100644 (file)
--- a/stdlib/camlinternalOO.ml
+++ b/stdlib/camlinternalOO.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,8 +18,7 @@ open Obj
 (**** Object representation ****)
 
 let last_id = ref 0
-let new_id () =
-  let id = !last_id in incr last_id; id
+let () = Callback.register "CamlinternalOO.last_id" last_id
 
 let set_id o id =
   let id0 = !id in

diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli
index d2aeea319b41639010a092cd2b382af055216f74..f02b02036061faeddec433ca8e1f1c458ff05a0e 100644 (file)
--- a/stdlib/camlinternalOO.mli
+++ b/stdlib/camlinternalOO.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/char.ml b/stdlib/char.ml
index 28a1bcc46c594857b7dc5228120826f78cbd9eae..6dafbad2b3938d941a75d1f098d600cfe88ae0fd 100644 (file)
--- a/stdlib/char.ml
+++ b/stdlib/char.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/char.mli b/stdlib/char.mli
index 8ab72bd9a60f9cc23960b5a3ad4beb2d6857d243..05a8156d3cfd1651eba89da2631880926fc1793c 100644 (file)
--- a/stdlib/char.mli
+++ b/stdlib/char.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,7 +26,7 @@ val chr : int -> char
 val escaped : char -> string
 (** Return a string representing the given character,
    with special characters escaped following the lexical conventions
-   of Objective Caml. *)
+   of OCaml. *)
 
 val lowercase : char -> char
 (** Convert the given character to its equivalent lowercase character. *)
@@ -45,4 +45,6 @@ val compare: t -> t -> int
 
 (**/**)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_chr : int -> char = "%identity"

diff --git a/stdlib/complex.ml b/stdlib/complex.ml
index 3c28a58b79099d7bafa04607c638558f5120fa47..c52e647cc92ea26f4ba27e40726b3e5ee01f3c6e 100644 (file)
--- a/stdlib/complex.ml
+++ b/stdlib/complex.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/complex.mli b/stdlib/complex.mli
index 3c3b361d27e4547dca2cf1c415596c2cecadf40a..1bfa8b7bc891182798a5c0afff30e47e5cae1b38 100644 (file)
--- a/stdlib/complex.mli
+++ b/stdlib/complex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/digest.ml b/stdlib/digest.ml
index 78a45d54ee78cb5560a03f159134e35a4702c7aa..38df61a038875bc01a7e04da77faf84ec196a377 100644 (file)
--- a/stdlib/digest.ml
+++ b/stdlib/digest.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -17,6 +17,8 @@
 
 type t = string
 
+let compare = String.compare
+
 external unsafe_string: string -> int -> int -> t = "caml_md5_string"
 external channel: in_channel -> int -> t = "caml_md5_chan"
 
@@ -48,4 +50,19 @@ let to_hex d =
     String.blit (Printf.sprintf "%02x" (int_of_char d.[i])) 0 result (2*i) 2;
   done;
   result
-;;
+
+let from_hex s =
+  if String.length s <> 32 then raise (Invalid_argument "Digest.from_hex");
+  let digit c =
+    match c with
+    | '0'..'9' -> Char.code c - Char.code '0'
+    | 'A'..'F' -> Char.code c - Char.code 'A' + 10
+    | 'a'..'f' -> Char.code c - Char.code 'a' + 10
+    | _ -> raise (Invalid_argument "Digest.from_hex")
+  in
+  let byte i = digit s.[i] lsl 4 + digit s.[i+1] in
+  let result = String.create 16 in
+  for i = 0 to 15 do
+    result.[i] <- Char.chr (byte (2 * i));
+  done;
+  result

diff --git a/stdlib/digest.mli b/stdlib/digest.mli
index 981bd02fc3e8918e36cada6c5fb02481f8b864ca..efc0a4773c5e24a348820184f48c8fb2cf62f444 100644 (file)
--- a/stdlib/digest.mli
+++ b/stdlib/digest.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,12 +18,23 @@
    This module provides functions to compute 128-bit ``digests'' of
    arbitrary-length strings or files. The digests are of cryptographic
    quality: it is very hard, given a digest, to forge a string having
-   that digest. The algorithm used is MD5.
+   that digest. The algorithm used is MD5. This module should not be
+   used for secure and sensitive cryptographic applications. For these
+   kind of applications more recent and stronger cryptographic
+   primitives should be used instead.
 *)
 
 type t = string
 (** The type of digests: 16-character strings. *)
 
+val compare : t -> t -> int
+(** The comparison function for 16-character digest, with the same
+    specification as {!Pervasives.compare} and the implementation
+    shared with {!String.compare}. Along with the type [t], this
+    function [compare] allows the module [Digest] to be passed as
+    argument to the functors {!Set.Make} and {!Map.Make}.
+    @since 4.00.0 *)
+
 val string : string -> t
 (** Return the digest of the given string. *)
 
@@ -51,3 +62,9 @@ val input : in_channel -> t
 
 val to_hex : t -> string
 (** Return the printable hexadecimal representation of the given digest. *)
+
+val from_hex : string -> t
+(** Convert a hexadecimal representation back into the corresponding digest.
+   Raise [Invalid_argument] if the argument is not exactly 32 hexadecimal
+   characters.
+   @since 4.00.0 *)

diff --git a/stdlib/filename.ml b/stdlib/filename.ml
index e11f1e3304881cc24e54d7f83e82e3d79f2f6193..3c147333e3d9aabf200ccb44b7fc1e7029893d6a 100644 (file)
--- a/stdlib/filename.ml
+++ b/stdlib/filename.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Xavier Leroy and Damien Doligez, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -25,30 +25,55 @@ let generic_quote quotequote s =
   Buffer.add_char b '\'';
   Buffer.contents b
 
-let generic_basename rindex_dir_sep current_dir_name name =
-  let raw_name =
-    try
-      let p = rindex_dir_sep name + 1 in
-      String.sub name p (String.length name - p)
-    with Not_found ->
-      name
+(* This function implements the Open Group specification found here:
+  [[1]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/basename.html
+  In step 1 of [[1]], we choose to return "." for empty input.
+    (for compatibility with previous versions of OCaml)
+  In step 2, we choose to process "//" normally.
+  Step 6 is not implemented: we consider that the [suffix] operand is
+    always absent.  Suffixes are handled by [chop_suffix] and [chop_extension].
+*)
+let generic_basename is_dir_sep current_dir_name name =
+  let rec find_end n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then find_end (n - 1)
+    else find_beg n (n + 1)
+  and find_beg n p =
+    if n < 0 then String.sub name 0 p
+    else if is_dir_sep name n then String.sub name (n + 1) (p - n - 1)
+    else find_beg (n - 1) p
   in
-  if raw_name = "" then current_dir_name else raw_name
-
-let generic_dirname rindex_dir_sep current_dir_name dir_sep name =
-  try
-    match rindex_dir_sep name with
-      0 -> dir_sep
-    | n -> String.sub name 0 n
-  with Not_found ->
-    current_dir_name
+  if name = ""
+  then current_dir_name
+  else find_end (String.length name - 1)
+
+(* This function implements the Open Group specification found here:
+  [[2]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/dirname.html
+  In step 6 of [[2]], we choose to process "//" normally.
+*)
+let generic_dirname is_dir_sep current_dir_name name =
+  let rec trailing_sep n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then trailing_sep (n - 1)
+    else base n
+  and base n =
+    if n < 0 then current_dir_name
+    else if is_dir_sep name n then intermediate_sep n
+    else base (n - 1)
+  and intermediate_sep n =
+    if n < 0 then String.sub name 0 1
+    else if is_dir_sep name n then intermediate_sep (n - 1)
+    else String.sub name 0 (n + 1)
+  in
+  if name = ""
+  then current_dir_name
+  else trailing_sep (String.length name - 1)
 
 module Unix = struct
   let current_dir_name = "."
   let parent_dir_name = ".."
   let dir_sep = "/"
   let is_dir_sep s i = s.[i] = '/'
-  let rindex_dir_sep s = String.rindex s '/'
   let is_relative n = String.length n < 1 || n.[0] <> '/';;
   let is_implicit n =
     is_relative n
@@ -61,8 +86,8 @@ module Unix = struct
   let temp_dir_name =
     try Sys.getenv "TMPDIR" with Not_found -> "/tmp"
   let quote = generic_quote "'\\''"
-  let basename = generic_basename rindex_dir_sep current_dir_name
-  let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
+  let basename = generic_basename is_dir_sep current_dir_name
+  let dirname = generic_dirname is_dir_sep current_dir_name
 end
 
 module Win32 = struct
@@ -70,12 +95,6 @@ module Win32 = struct
   let parent_dir_name = ".."
   let dir_sep = "\\"
   let is_dir_sep s i = let c = s.[i] in c = '/' || c = '\\' || c = ':'
-  let rindex_dir_sep s =
-    let rec pos i =
-      if i < 0 then raise Not_found
-      else if is_dir_sep s i then i
-      else pos (i - 1)
-    in pos (String.length s - 1)
   let is_relative n =
     (String.length n < 1 || n.[0] <> '/')
     && (String.length n < 1 || n.[0] <> '\\')
@@ -129,11 +148,11 @@ module Win32 = struct
     else ("", s)
   let dirname s =
     let (drive, path) = drive_and_path s in
-    let dir = generic_dirname rindex_dir_sep current_dir_name dir_sep path in
+    let dir = generic_dirname is_dir_sep current_dir_name path in
     drive ^ dir
   let basename s =
     let (drive, path) = drive_and_path s in
-    generic_basename rindex_dir_sep current_dir_name path
+    generic_basename is_dir_sep current_dir_name path
 end
 
 module Cygwin = struct
@@ -141,33 +160,32 @@ module Cygwin = struct
   let parent_dir_name = ".."
   let dir_sep = "/"
   let is_dir_sep = Win32.is_dir_sep
-  let rindex_dir_sep = Win32.rindex_dir_sep
   let is_relative = Win32.is_relative
   let is_implicit = Win32.is_implicit
   let check_suffix = Win32.check_suffix
   let temp_dir_name = Unix.temp_dir_name
   let quote = Unix.quote
-  let basename = generic_basename rindex_dir_sep current_dir_name
-  let dirname = generic_dirname rindex_dir_sep current_dir_name dir_sep
+  let basename = generic_basename is_dir_sep current_dir_name
+  let dirname = generic_dirname is_dir_sep current_dir_name
 end
 
-let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep, rindex_dir_sep,
+let (current_dir_name, parent_dir_name, dir_sep, is_dir_sep,
      is_relative, is_implicit, check_suffix, temp_dir_name, quote, basename,
      dirname) =
   match Sys.os_type with
     "Unix" ->
       (Unix.current_dir_name, Unix.parent_dir_name, Unix.dir_sep,
-       Unix.is_dir_sep, Unix.rindex_dir_sep,
+       Unix.is_dir_sep,
        Unix.is_relative, Unix.is_implicit, Unix.check_suffix,
        Unix.temp_dir_name, Unix.quote, Unix.basename, Unix.dirname)
   | "Win32" ->
       (Win32.current_dir_name, Win32.parent_dir_name, Win32.dir_sep,
-       Win32.is_dir_sep, Win32.rindex_dir_sep,
+       Win32.is_dir_sep,
        Win32.is_relative, Win32.is_implicit, Win32.check_suffix,
        Win32.temp_dir_name, Win32.quote, Win32.basename, Win32.dirname)
   | "Cygwin" ->
       (Cygwin.current_dir_name, Cygwin.parent_dir_name, Cygwin.dir_sep,
-       Cygwin.is_dir_sep, Cygwin.rindex_dir_sep,
+       Cygwin.is_dir_sep,
        Cygwin.is_relative, Cygwin.is_implicit, Cygwin.check_suffix,
        Cygwin.temp_dir_name, Cygwin.quote, Cygwin.basename, Cygwin.dirname)
   | _ -> assert false
@@ -199,7 +217,12 @@ let temp_file_name temp_dir prefix suffix =
   concat temp_dir (Printf.sprintf "%s%06x%s" prefix rnd suffix)
 ;;
 
-let temp_file ?(temp_dir=temp_dir_name) prefix suffix =
+let current_temp_dir_name = ref temp_dir_name
+
+let set_temp_dir_name s = current_temp_dir_name := s
+let get_temp_dir_name () = !current_temp_dir_name
+
+let temp_file ?(temp_dir = !current_temp_dir_name) prefix suffix =
   let rec try_name counter =
     let name = temp_file_name temp_dir prefix suffix in
     try
@@ -209,7 +232,7 @@ let temp_file ?(temp_dir=temp_dir_name) prefix suffix =
       if counter >= 1000 then raise e else try_name (counter + 1)
   in try_name 0
 
-let open_temp_file ?(mode = [Open_text]) ?(temp_dir=temp_dir_name) prefix suffix =
+let open_temp_file ?(mode = [Open_text]) ?(temp_dir = !current_temp_dir_name) prefix suffix =
   let rec try_name counter =
     let name = temp_file_name temp_dir prefix suffix in
     try

diff --git a/stdlib/filename.mli b/stdlib/filename.mli
index efbdcd98d509be52309d6ef4d907e1e1622484da..499e8bb29126b81d7738e6744d5deb40d99bb458 100644 (file)
--- a/stdlib/filename.mli
+++ b/stdlib/filename.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -59,17 +59,19 @@ val chop_extension : string -> string
 
 val basename : string -> string
 (** Split a file name into directory name / base file name.
-   [concat (dirname name) (basename name)] returns a file name
-   which is equivalent to [name]. Moreover, after setting the
-   current directory to [dirname name] (with {!Sys.chdir}),
+   If [name] is a valid file name, then [concat (dirname name) (basename name)]
+   returns a file name which is equivalent to [name]. Moreover,
+   after setting the current directory to [dirname name] (with {!Sys.chdir}),
    references to [basename name] (which is a relative file name)
    designate the same file as [name] before the call to {!Sys.chdir}.
 
-   The result is not specified if the argument is not a valid file name
-   (for example, under Unix if there is a NUL character in the string). *)
+   This function conforms to the specification of POSIX.1-2008 for the
+   [basename] utility. *)
 
 val dirname : string -> string
-(** See {!Filename.basename}. *)
+(** See {!Filename.basename}.
+   This function conforms to the specification of POSIX.1-2008 for the
+   [dirname] utility. *)
 
 val temp_file : ?temp_dir: string -> string -> string -> string
 (** [temp_file prefix suffix] returns the name of a
@@ -77,7 +79,7 @@ val temp_file : ?temp_dir: string -> string -> string -> string
    The base name of the temporary file is formed by concatenating
    [prefix], then a suitably chosen integer number, then [suffix].
    The optional argument [temp_dir] indicates the temporary directory
-   to use, defaulting to {!Filename.temp_dir_name}.
+   to use, defaulting to the current result of {!Filename.get_temp_dir_name}.
    The temporary file is created empty, with permissions [0o600]
    (readable and writable only by the file owner).  The file is
    guaranteed to be different from any other file that existed when
@@ -100,12 +102,30 @@ val open_temp_file :
    @before 3.11.2 no ?temp_dir optional argument
 *)
 
-val temp_dir_name : string
+val get_temp_dir_name : unit -> string
 (** The name of the temporary directory:
     Under Unix, the value of the [TMPDIR] environment variable, or "/tmp"
     if the variable is not set.
     Under Windows, the value of the [TEMP] environment variable, or "."
     if the variable is not set.
+    The temporary directory can be changed with {!Filename.set_temp_dir_name}.
+    @since 4.00.0
+*)
+
+val set_temp_dir_name : string -> unit
+(** Change the temporary directory returned by {!Filename.get_temp_dir_name}
+    and used by {!Filename.temp_file} and {!Filename.open_temp_file}.
+    @since 4.00.0
+*)
+
+val temp_dir_name : string
+(** @deprecated  The name of the initial temporary directory:
+    Under Unix, the value of the [TMPDIR] environment variable, or "/tmp"
+    if the variable is not set.
+    Under Windows, the value of the [TEMP] environment variable, or "."
+    if the variable is not set.
+    This function is deprecated; {!Filename.get_temp_dir_name} should be
+    used instead.
     @since 3.09.1
 *)
 

diff --git a/stdlib/format.ml b/stdlib/format.ml
index a8d6ec9e1486f0045f36d76a6878bb601e768daf..28bb5f1c5968a9f41338d1ad5dcd52276efd342d 100644 (file)
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -60,7 +60,8 @@ and block_type =
                when it leads to a new indentation of the current line *)
 | Pp_fits   (* Internal usage: when a block fits on a single line *)
 
-and tblock = Pp_tbox of int list ref  (* Tabulation box *)
+and tblock =
+  | Pp_tbox of int list ref  (* Tabulation box *)
 ;;
 
 (* The Queue:
@@ -182,28 +183,30 @@ let clear_queue q = q.insert <- Nil; q.body <- Nil;;
 let add_queue x q =
   let c = Cons { head = x; tail = Nil; } in
   match q with
-  | { insert = Cons cell } ->
+  | { insert = Cons cell; body = _; } ->
     q.insert <- c; cell.tail <- c
   (* Invariant: when insert is Nil body should be Nil. *)
-  | _ -> q.insert <- c; q.body <- c;;
+  | { insert = Nil; body = _; } ->
+    q.insert <- c; q.body <- c
+;;
 
 exception Empty_queue;;
 
 let peek_queue = function
-  | { body = Cons { head = x; }; } -> x
-  | _ -> raise Empty_queue
+  | { body = Cons { head = x; tail = _; }; _ } -> x
+  | { body = Nil; insert = _; } -> raise Empty_queue
 ;;
 
 let take_queue = function
-  | { body = Cons { head = x; tail = tl; }; } as q ->
+  | { body = Cons { head = x; tail = tl; }; _ } as q ->
     q.body <- tl;
     if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *)
     x
-  | _ -> raise Empty_queue
+  | { body = Nil; insert = _; } -> raise Empty_queue
 ;;
 
 (* Enter a token in the pretty-printer queue. *)
-let pp_enqueue state ({length = len} as token) =
+let pp_enqueue state ({ length = len; _} as token) =
   state.pp_right_total <- state.pp_right_total + len;
   add_queue token state.pp_queue
 ;;
@@ -272,15 +275,16 @@ let pp_force_break_line state =
     if width > state.pp_space_left then
       (match bl_ty with
        | Pp_fits -> () | Pp_hbox -> ()
-       | _ -> break_line state width)
-  | _ -> pp_output_newline state
+       | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box ->
+         break_line state width)
+  | [] -> pp_output_newline state
 ;;
 
 (* To skip a token, if the previous line has been broken. *)
 let pp_skip_token state =
   (* When calling pp_skip_token the queue cannot be empty. *)
   match take_queue state.pp_queue with
-  | { elem_size = size; length = len; } ->
+  | { elem_size = size; length = len; token = _; } ->
     state.pp_left_total <- state.pp_left_total - len;
     state.pp_space_left <- state.pp_space_left + int_of_size size
 ;;
@@ -308,15 +312,16 @@ let format_pp_token state size = function
     let bl_type =
       begin match ty with
       | Pp_vbox -> Pp_vbox
-      | _ -> if size > state.pp_space_left then ty else Pp_fits
+      | Pp_hbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits ->
+        if size > state.pp_space_left then ty else Pp_fits
       end in
     state.pp_format_stack <-
       Format_elem (bl_type, offset) :: state.pp_format_stack
 
   | Pp_end ->
     begin match state.pp_format_stack with
-    | x :: (y :: l as ls) -> state.pp_format_stack <- ls
-    | _ -> () (* No more block to close. *)
+    | _ :: ls -> state.pp_format_stack <- ls
+    | [] -> () (* No more block to close. *)
     end
 
   | Pp_tbegin (Pp_tbox _ as tbox) ->
@@ -324,8 +329,8 @@ let format_pp_token state size = function
 
   | Pp_tend ->
     begin match state.pp_tbox_stack with
-    | x :: ls -> state.pp_tbox_stack <- ls
-    | _ -> () (* No more tabulation block to close. *)
+    | _ :: ls -> state.pp_tbox_stack <- ls
+    | [] -> () (* No more tabulation block to close. *)
     end
 
   | Pp_stab ->
@@ -335,7 +340,7 @@ let format_pp_token state size = function
         | [] -> [n]
         | x :: l as ls -> if n < x then n :: ls else x :: add_tab n l in
       tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs
-    | _ -> () (* No opened tabulation block. *)
+    | [] -> () (* No opened tabulation block. *)
     end
 
   | Pp_tbreak (n, off) ->
@@ -347,7 +352,7 @@ let format_pp_token state size = function
         | [] -> raise Not_found in
       let tab =
         match !tabs with
-        | x :: l ->
+        | x :: _ ->
           begin
             try find insertion_point !tabs with
             | Not_found -> x
@@ -357,13 +362,13 @@ let format_pp_token state size = function
       if offset >= 0
       then break_same_line state (offset + n)
       else break_new_line state (tab + off) state.pp_margin
-    | _ -> () (* No opened tabulation block. *)
+    | [] -> () (* No opened tabulation block. *)
     end
 
   | Pp_newline ->
     begin match state.pp_format_stack with
     | Format_elem (_, width) :: _ -> break_line state width
-    | _ -> pp_output_newline state
+    | [] -> pp_output_newline state (* No opened block. *)
     end
 
   | Pp_if_newline ->
@@ -392,7 +397,7 @@ let format_pp_token state size = function
       | Pp_vbox -> break_new_line state off width
       | Pp_hbox -> break_same_line state n
       end
-    | _ -> () (* No opened block. *)
+    | [] -> () (* No opened block. *)
     end
 
    | Pp_open_tag tag_name ->
@@ -406,7 +411,7 @@ let format_pp_token state size = function
        let marker = state.pp_mark_close_tag tag_name in
        pp_output_string state marker;
        state.pp_mark_stack <- tags
-     | _ -> () (* No more tag to close. *)
+     | [] -> () (* No more tag to close. *)
      end
 ;;
 
@@ -474,7 +479,7 @@ let set_size state ty =
   match state.pp_scan_stack with
   | Scan_elem
       (left_tot,
-       ({elem_size = size; token = tok} as queue_elem)) :: t ->
+       ({ elem_size = size; token = tok; length = _; } as queue_elem)) :: t ->
     let size = int_of_size size in
     (* test if scan stack contains any data that is not obsolete. *)
     if left_tot < state.pp_left_total then clear_scan_stack state else
@@ -491,9 +496,12 @@ let set_size state ty =
           queue_elem.elem_size <- size_of_int (state.pp_right_total + size);
           state.pp_scan_stack <- t
         end
-      | _ -> () (* scan_push is only used for breaks and boxes. *)
+      | Pp_text _ | Pp_stab | Pp_tbegin _ | Pp_tend | Pp_end
+      | Pp_newline | Pp_if_newline
+      | Pp_open_tag _ | Pp_close_tag ->
+        () (* scan_push is only used for breaks and boxes. *)
       end
-  | _ -> () (* scan_stack is never empty. *)
+  | [] -> () (* scan_stack is never empty. *)
 ;;
 
 (* Push a token on scan stack. If b is true set_size is called. *)
@@ -847,7 +855,7 @@ let pp_set_formatter_out_channel state os =
 let default_pp_mark_open_tag s = "<" ^ s ^ ">";;
 let default_pp_mark_close_tag s = "</" ^ s ^ ">";;
 
-let default_pp_print_open_tag s = ();;
+let default_pp_print_open_tag _ = ();;
 let default_pp_print_close_tag = default_pp_print_open_tag;;
 
 let pp_make_formatter f g h i =
@@ -1011,11 +1019,12 @@ module Tformat = Printf.CamlinternalPr.Tformat;;
 
 (* Trailer: giving up at character number ... *)
 let giving_up mess fmt i =
-  "fprintf: " ^ mess ^ " ``" ^ Sformat.to_string fmt ^ "'', \
-   giving up at character number " ^ string_of_int i ^
-  (if i < Sformat.length fmt
-   then " (" ^ String.make 1 (Sformat.get fmt i) ^ ")."
-   else String.make 1 '.')
+  Printf.sprintf
+    "Format.fprintf: %s ``%s'', giving up at character number %d%s"
+    mess (Sformat.to_string fmt) i
+    (if i < Sformat.length fmt
+     then Printf.sprintf " (%c)." (Sformat.get fmt i)
+     else Printf.sprintf "%c" '.')
 ;;
 
 (* When an invalid format deserves a special error explanation. *)
@@ -1028,11 +1037,11 @@ let invalid_format fmt i = format_invalid_arg "bad format" fmt i;;
 let invalid_integer fmt i =
   invalid_arg (giving_up "bad integer specification" fmt i);;
 
-(* Finding an integer out of a sub-string of the format. *)
+(* Finding an integer size out of a sub-string of the format. *)
 let format_int_of_string fmt i s =
   let sz =
     try int_of_string s with
-    | Failure s -> invalid_integer fmt i in
+    | Failure _ -> invalid_integer fmt i in
   size_of_int sz
 ;;
 
@@ -1110,7 +1119,7 @@ let mkprintf to_s get_out =
           | '[' ->
             do_pp_open_box ppf n (succ i)
           | ']' ->
-             pp_close_box ppf ();
+            pp_close_box ppf ();
             doprn n (succ i)
           | '{' ->
             do_pp_open_tag ppf n (succ i)
@@ -1139,10 +1148,10 @@ let mkprintf to_s get_out =
               print_as := Some size;
               doprn n (skip_gt i) in
             get_int n (succ i) got_size
-          | '@' as c ->
+          | '@' | '%' as c ->
             pp_print_as_char c;
             doprn n (succ i)
-          | c -> invalid_format fmt i
+          | _ -> invalid_format fmt i
           end
         | c ->
           pp_print_as_char c;
@@ -1173,10 +1182,10 @@ let mkprintf to_s get_out =
         | ' ' -> get_int n (succ i) c
         | '%' ->
           let cont_s n s i = c (format_int_of_string fmt i s) n i
-          and cont_a n printer arg i = invalid_integer fmt i
-          and cont_t n printer i = invalid_integer fmt i
-          and cont_f n i = invalid_integer fmt i
-          and cont_m n sfmt i = invalid_integer fmt i in
+          and cont_a _n _printer _arg i = invalid_integer fmt i
+          and cont_t _n _printer i = invalid_integer fmt i
+          and cont_f _n i = invalid_integer fmt i
+          and cont_m _n _sfmt i = invalid_integer fmt i in
           Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
         | _ ->
           let rec get j =
@@ -1185,7 +1194,7 @@ let mkprintf to_s get_out =
             | '0' .. '9' | '-' -> get (succ j)
             | _ ->
               let size =
-              if j = i then size_of_int 0 else
+                if j = i then size_of_int 0 else
                 let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
                 format_int_of_string fmt j s in
               c size n j in
@@ -1215,7 +1224,7 @@ let mkprintf to_s get_out =
                  ("bad box name ho" ^ String.make 1 c) fmt i
              end
            | 'v' -> Pp_hvbox, succ i
-           | c -> Pp_hbox, i
+           | _ -> Pp_hbox, i
            end
         | 'b' -> Pp_box, succ i
         | 'v' -> Pp_vbox, succ i
@@ -1249,12 +1258,12 @@ let mkprintf to_s get_out =
                 then (Obj.magic printer : unit -> string) ()
                 else exstring (fun ppf () -> printer ppf) () in
               get (s :: s0 :: accu) n i i
-            and cont_f n i =
+            and cont_f _n i =
               format_invalid_arg "bad tag name specification" fmt i
-            and cont_m n sfmt i =
+            and cont_m _n _sfmt i =
               format_invalid_arg "bad tag name specification" fmt i in
             Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
-          | c -> get accu n i (succ j) in
+          | _ -> get accu n i (succ j) in
         get [] n i i
 
       and do_pp_break ppf n i =
@@ -1267,7 +1276,7 @@ let mkprintf to_s get_out =
             pp_print_break ppf (int_of_size nspaces) (int_of_size offset);
             doprn n (skip_gt i) in
           get_int n (succ i) got_nspaces
-        | c -> pp_print_space ppf (); doprn n i
+        | _c -> pp_print_space ppf (); doprn n i
 
       and do_pp_open_box ppf n i =
         if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else
@@ -1278,7 +1287,7 @@ let mkprintf to_s get_out =
             pp_open_box_gen ppf (int_of_size size) kind;
             doprn n (skip_gt i) in
           get_int n i got_size
-        | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
+        | _c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
 
       and do_pp_open_tag ppf n i =
         if i >= len then begin pp_open_tag ppf ""; doprn n i end else
@@ -1288,7 +1297,7 @@ let mkprintf to_s get_out =
             pp_open_tag ppf tag_name;
             doprn n (skip_gt i) in
           get_tag_name n (succ i) got_name
-        | c -> pp_open_tag ppf ""; doprn n i in
+        | _c -> pp_open_tag ppf ""; doprn n i in
 
       doprn (Sformat.index_of_int 0) 0 in
 

diff --git a/stdlib/format.mli b/stdlib/format.mli
index 9b49c53f464735bc1dcf8615adfbcadd196199ec..4831fe02021b680cb04e59d90e8f67558f311e2f 100644 (file)
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -22,7 +22,8 @@
 
    For a gentle introduction to the basics of pretty-printing using
    [Format], read
-   {{:http://caml.inria.fr/resources/doc/guides/format.html}http://caml.inria.fr/resources/doc/guides/format.html}.
+   {{:http://caml.inria.fr/resources/doc/guides/format.en.html}
+    http://caml.inria.fr/resources/doc/guides/format.en.html}.
 
    You may consider this module as providing an extension to the
    [printf] facility to provide automatic line breaking. The addition of
@@ -404,7 +405,7 @@ val get_all_formatter_output_functions :
    including line breaking and indentation functions. Useful to record the
    current setting and restore it afterwards. *)
 
-(** {6:tags Changing the meaning of printing semantics tags} *)
+(** {6:tagsmeaning Changing the meaning of printing semantics tags} *)
 
 type formatter_tag_functions = {
   mark_open_tag : tag -> string;
@@ -617,7 +618,7 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
    - [@.]: flush the pretty printer and output a new line, as with
      [print_newline ()].
    - [@<n>]: print the following item as if it were of length [n].
-     Hence, [printf "@<0>%s" arg] is equivalent to [print_as 0 arg].
+     Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string.
      If [@<n>] is not followed by a conversion specification,
      then the following character of the format is printed as if
      it were of length [n].
@@ -631,12 +632,19 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
      For more details about tags, see the functions [open_tag] and
      [close_tag].
    - [@\}]: close the most recently opened tag.
-   - [@@]: print a plain [@] character.
+   - [@%]: print a plain [%] character.
 
    Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to
    [open_box (); print_string "x ="; print_space ();
     print_int 1; close_box (); print_newline ()].
    It prints [x = 1] within a pretty-printing box.
+
+   Note: the old [@@] ``pretty-printing indication'' is now deprecated, since
+   it had no pretty-printing indication semantics. If you need to prevent
+   the pretty-printing indication interpretation of a [@] character, simply
+   use the regular way to escape a character in format string: write [%@].
+   @since 3.12.2.
+
 *)
 
 val printf : ('a, formatter, unit) format -> 'a;;

diff --git a/stdlib/gc.ml b/stdlib/gc.ml
index 6482ebb78b7dc084d7196073aad5b02f2c7be534..16a354a35f00cf7dae2da44b129c838bd09a7bc2 100644 (file)
--- a/stdlib/gc.ml
+++ b/stdlib/gc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)

diff --git a/stdlib/gc.mli b/stdlib/gc.mli
index 33e794dc142b9d3a181b176f7bb5bdd85afcbfeb..45d882f25a5cb01e101aa6fe57824741cc22c497 100644 (file)
--- a/stdlib/gc.mli
+++ b/stdlib/gc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -123,6 +123,8 @@ type control =
        compaction is triggered at the end of each major GC cycle
        (this setting is intended for testing purposes only).
        If [max_overhead >= 1000000], compaction is never triggered.
+       If compaction is permanently disabled, it is strongly suggested
+       to set [allocation_policy] to 1.
        Default: 500. *)
 
     mutable stack_limit : int;
@@ -141,7 +143,7 @@ type control =
 (** The GC parameters are given as a [control] record.  Note that
     these parameters can also be initialised by setting the
     OCAMLRUNPARAM environment variable.  See the documentation of
-    ocamlrun. *)
+    [ocamlrun]. *)
 
 external stat : unit -> stat = "caml_gc_stat"
 (** Return the current values of the memory management counters in a
@@ -156,7 +158,7 @@ external quick_stat : unit -> stat = "caml_gc_quick_stat"
 
 external counters : unit -> float * float * float = "caml_gc_counters"
 (** Return [(minor_words, promoted_words, major_words)].  This function
-    is as fast at [quick_stat]. *)
+    is as fast as [quick_stat]. *)
 
 external get : unit -> control = "caml_gc_get"
 (** Return the current values of the GC parameters in a [control] record. *)
@@ -221,7 +223,7 @@ val finalise : ('a -> unit) -> 'a -> unit
    - [ let f = fun x -> ... ;; let v = ... in Gc.finalise f v ]
 
 
-   The [f] function can use all features of O'Caml, including
+   The [f] function can use all features of OCaml, including
    assignments that make the value reachable again.  It can also
    loop forever (in this case, the other
    finalisation functions will not be called during the execution of f,

diff --git a/stdlib/genlex.ml b/stdlib/genlex.ml
index 6ecc2805a91d902ee912a448c49cdcc9f98c3280..1c6276c9f9466e0cbfe615e0712a684e04663af3 100644 (file)
--- a/stdlib/genlex.ml
+++ b/stdlib/genlex.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Xavier Leroy, projet Cristal, INRIA Rocquencourt       *)
 (*                                                                     *)

diff --git a/stdlib/genlex.mli b/stdlib/genlex.mli
index 93bc5f55e8cae99f1d8653bfbcfb0f92cf4dbe39..b1098f0977ff2c0ad115e65b537a764950048f1c 100644 (file)
--- a/stdlib/genlex.mli
+++ b/stdlib/genlex.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Xavier Leroy, projet Cristal, INRIA Rocquencourt       *)
 (*                                                                     *)
@@ -18,7 +18,7 @@
 
    This module implements a simple ``standard'' lexical analyzer, presented
    as a function from character streams to token streams. It implements
-   roughly the lexical conventions of Caml, but is parameterized by the
+   roughly the lexical conventions of OCaml, but is parameterized by the
    set of keywords of your language.
 
 
@@ -37,6 +37,11 @@
                   [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2
                 | ...
    ]}
+
+   One should notice that the use of the [parser] keyword and associated
+   notation for streams are only available through camlp4 extensions. This
+   means that one has to preprocess its sources {i e. g.} by using the
+   ["-pp"] command-line switch of the compilers.
 *)
 
 (** The type of tokens. The lexical classes are: [Int] and [Float]

diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml
index bcb2c9275a669ba1652ee3ea4e2350f3da37874a..6f3ea880b619e8cf2df39a03ad2039479513f125 100644 (file)
--- a/stdlib/hashtbl.ml
+++ b/stdlib/hashtbl.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -15,24 +15,33 @@
 
 (* Hash tables *)
 
-external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
+external seeded_hash_param : int -> int -> int -> 'a -> int = "caml_hash" "noalloc"
+external old_hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
 
-let hash x = hash_param 10 100 x
+let hash x = seeded_hash_param 10 100 0 x
+let hash_param n1 n2 x = seeded_hash_param n1 n2 0 x
+let seeded_hash seed x = seeded_hash_param 10 100 seed x
 
 (* We do dynamic hashing, and resize the table and rehash the elements
    when buckets become too long. *)
 
 type ('a, 'b) t =
-  { mutable size: int;                        (* number of elements *)
-    mutable data: ('a, 'b) bucketlist array } (* the buckets *)
+  { mutable size: int;                        (* number of entries *)
+    mutable data: ('a, 'b) bucketlist array;  (* the buckets *)
+    mutable seed: int }                       (* for randomization *)
 
 and ('a, 'b) bucketlist =
     Empty
   | Cons of 'a * 'b * ('a, 'b) bucketlist
 
-let create initial_size =
-  let s = min (max 1 initial_size) Sys.max_array_length in
-  { size = 0; data = Array.make s Empty }
+let rec power_2_above x n =
+  if x >= n then x
+  else if x * 2 > Sys.max_array_length then x
+  else power_2_above (x * 2) n
+
+let create ?(seed = 0) initial_size =
+  let s = power_2_above 16 initial_size in
+  { size = 0; seed = seed; data = Array.make s Empty }
 
 let clear h =
   for i = 0 to Array.length h.data - 1 do
@@ -40,94 +49,98 @@ let clear h =
   done;
   h.size <- 0
 
-let copy h =
-  { size = h.size;
-    data = Array.copy h.data }
+let copy h = { h with data = Array.copy h.data }
 
 let length h = h.size
 
-let resize hashfun tbl =
-  let odata = tbl.data in
+let resize indexfun h =
+  let odata = h.data in
   let osize = Array.length odata in
-  let nsize = min (2 * osize + 1) Sys.max_array_length in
-  if nsize <> osize then begin
+  let nsize = osize * 2 in
+  if nsize < Sys.max_array_length then begin
     let ndata = Array.create nsize Empty in
+    h.data <- ndata;          (* so that indexfun sees the new bucket count *)
     let rec insert_bucket = function
         Empty -> ()
       | Cons(key, data, rest) ->
           insert_bucket rest; (* preserve original order of elements *)
-          let nidx = (hashfun key) mod nsize in
+          let nidx = indexfun h key in
           ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in
     for i = 0 to osize - 1 do
       insert_bucket odata.(i)
-    done;
-    tbl.data <- ndata;
+    done
   end
 
+let key_index h key =
+  (* compatibility with old hash tables *)
+  if Obj.size (Obj.repr h) = 3
+  then (seeded_hash_param 10 100 h.seed key) land (Array.length h.data - 1)
+  else (old_hash_param 10 100 key) mod (Array.length h.data)
+
 let add h key info =
-  let i = (hash key) mod (Array.length h.data) in
+  let i = key_index h key in
   let bucket = Cons(key, info, h.data.(i)) in
   h.data.(i) <- bucket;
-  h.size <- succ h.size;
-  if h.size > Array.length h.data lsl 1 then resize hash h
+  h.size <- h.size + 1;
+  if h.size > Array.length h.data lsl 1 then resize key_index h
 
 let remove h key =
   let rec remove_bucket = function
-      Empty ->
+    | Empty ->
         Empty
     | Cons(k, i, next) ->
         if compare k key = 0
-        then begin h.size <- pred h.size; next end
+        then begin h.size <- h.size - 1; next end
         else Cons(k, i, remove_bucket next) in
-  let i = (hash key) mod (Array.length h.data) in
+  let i = key_index h key in
   h.data.(i) <- remove_bucket h.data.(i)
 
 let rec find_rec key = function
-    Empty ->
+  | Empty ->
       raise Not_found
   | Cons(k, d, rest) ->
       if compare key k = 0 then d else find_rec key rest
 
 let find h key =
-  match h.data.((hash key) mod (Array.length h.data)) with
-    Empty -> raise Not_found
+  match h.data.(key_index h key) with
+  | Empty -> raise Not_found
   | Cons(k1, d1, rest1) ->
       if compare key k1 = 0 then d1 else
       match rest1 with
-        Empty -> raise Not_found
+      | Empty -> raise Not_found
       | Cons(k2, d2, rest2) ->
           if compare key k2 = 0 then d2 else
           match rest2 with
-            Empty -> raise Not_found
+          | Empty -> raise Not_found
           | Cons(k3, d3, rest3) ->
               if compare key k3 = 0 then d3 else find_rec key rest3
 
 let find_all h key =
   let rec find_in_bucket = function
-    Empty ->
+  | Empty ->
       []
   | Cons(k, d, rest) ->
       if compare k key = 0
       then d :: find_in_bucket rest
       else find_in_bucket rest in
-  find_in_bucket h.data.((hash key) mod (Array.length h.data))
+  find_in_bucket h.data.(key_index h key)
 
 let replace h key info =
   let rec replace_bucket = function
-      Empty ->
+    | Empty ->
         raise Not_found
     | Cons(k, i, next) ->
         if compare k key = 0
-        then Cons(k, info, next)
+        then Cons(key, info, next)
         else Cons(k, i, replace_bucket next) in
-  let i = (hash key) mod (Array.length h.data) in
+  let i = key_index h key in
   let l = h.data.(i) in
   try
     h.data.(i) <- replace_bucket l
   with Not_found ->
     h.data.(i) <- Cons(key, info, l);
-    h.size <- succ h.size;
-    if h.size > Array.length h.data lsl 1 then resize hash h
+    h.size <- h.size + 1;
+    if h.size > Array.length h.data lsl 1 then resize key_index h
 
 let mem h key =
   let rec mem_in_bucket = function
@@ -135,11 +148,11 @@ let mem h key =
       false
   | Cons(k, d, rest) ->
       compare k key = 0 || mem_in_bucket rest in
-  mem_in_bucket h.data.((hash key) mod (Array.length h.data))
+  mem_in_bucket h.data.(key_index h key)
 
 let iter f h =
   let rec do_bucket = function
-      Empty ->
+    | Empty ->
         ()
     | Cons(k, d, rest) ->
         f k d; do_bucket rest in
@@ -162,6 +175,31 @@ let fold f h init =
   done;
   !accu
 
+type statistics = {
+  num_bindings: int;
+  num_buckets: int;
+  max_bucket_length: int;
+  bucket_histogram: int array
+}
+
+let rec bucket_length accu = function
+  | Empty -> accu
+  | Cons(_, _, rest) -> bucket_length (accu + 1) rest
+
+let stats h =
+  let mbl =
+    Array.fold_left (fun m b -> max m (bucket_length 0 b)) 0 h.data in
+  let histo = Array.make (mbl + 1) 0 in
+  Array.iter
+    (fun b ->
+      let l = bucket_length 0 b in
+      histo.(l) <- histo.(l) + 1)
+    h.data;
+  { num_bindings = h.size;
+    num_buckets = Array.length h.data;
+    max_bucket_length = mbl;
+    bucket_histogram = histo }
+
 (* Functorial interface *)
 
 module type HashedType =
@@ -171,6 +209,13 @@ module type HashedType =
     val hash: t -> int
   end
 
+module type SeededHashedType =
+  sig
+    type t
+    val equal: t -> t -> bool
+    val hash: int -> t -> int
+  end
+
 module type S =
   sig
     type key
@@ -187,9 +232,29 @@ module type S =
     val iter: (key -> 'a -> unit) -> 'a t -> unit
     val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
     val length: 'a t -> int
+    val stats: 'a t -> statistics
   end
 
-module Make(H: HashedType): (S with type key = H.t) =
+module type SeededS =
+  sig
+    type key
+    type 'a t
+    val create : ?seed:int -> int -> 'a t
+    val clear : 'a t -> unit
+    val copy : 'a t -> 'a t
+    val add : 'a t -> key -> 'a -> unit
+    val remove : 'a t -> key -> unit
+    val find : 'a t -> key -> 'a
+    val find_all : 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length : 'a t -> int
+    val stats: 'a t -> statistics
+  end
+
+module MakeSeeded(H: SeededHashedType): (SeededS with type key = H.t) =
   struct
     type key = H.t
     type 'a hashtbl = (key, 'a) t
@@ -198,72 +263,73 @@ module Make(H: HashedType): (S with type key = H.t) =
     let clear = clear
     let copy = copy
 
-    let safehash key = (H.hash key) land max_int
+    let key_index h key =
+      (H.hash h.seed key) land (Array.length h.data - 1)
 
     let add h key info =
-      let i = (safehash key) mod (Array.length h.data) in
+      let i = key_index h key in
       let bucket = Cons(key, info, h.data.(i)) in
       h.data.(i) <- bucket;
-      h.size <- succ h.size;
-      if h.size > Array.length h.data lsl 1 then resize safehash h
+      h.size <- h.size + 1;
+      if h.size > Array.length h.data lsl 1 then resize key_index h
 
     let remove h key =
       let rec remove_bucket = function
-          Empty ->
+        | Empty ->
             Empty
         | Cons(k, i, next) ->
             if H.equal k key
-            then begin h.size <- pred h.size; next end
+            then begin h.size <- h.size - 1; next end
             else Cons(k, i, remove_bucket next) in
-      let i = (safehash key) mod (Array.length h.data) in
+      let i = key_index h key in
       h.data.(i) <- remove_bucket h.data.(i)
 
     let rec find_rec key = function
-        Empty ->
+      | Empty ->
           raise Not_found
       | Cons(k, d, rest) ->
           if H.equal key k then d else find_rec key rest
 
     let find h key =
-      match h.data.((safehash key) mod (Array.length h.data)) with
-        Empty -> raise Not_found
+      match h.data.(key_index h key) with
+      | Empty -> raise Not_found
       | Cons(k1, d1, rest1) ->
           if H.equal key k1 then d1 else
           match rest1 with
-            Empty -> raise Not_found
+          | Empty -> raise Not_found
           | Cons(k2, d2, rest2) ->
               if H.equal key k2 then d2 else
               match rest2 with
-                Empty -> raise Not_found
+              | Empty -> raise Not_found
               | Cons(k3, d3, rest3) ->
                   if H.equal key k3 then d3 else find_rec key rest3
 
     let find_all h key =
       let rec find_in_bucket = function
-        Empty ->
+      | Empty ->
           []
       | Cons(k, d, rest) ->
           if H.equal k key
           then d :: find_in_bucket rest
           else find_in_bucket rest in
-      find_in_bucket h.data.((safehash key) mod (Array.length h.data))
+      find_in_bucket h.data.(key_index h key)
 
     let replace h key info =
       let rec replace_bucket = function
-          Empty ->
+        | Empty ->
             raise Not_found
         | Cons(k, i, next) ->
             if H.equal k key
-            then Cons(k, info, next)
+            then Cons(key, info, next)
             else Cons(k, i, replace_bucket next) in
-      let i = (safehash key) mod (Array.length h.data) in
+      let i = key_index h key in
       let l = h.data.(i) in
       try
         h.data.(i) <- replace_bucket l
       with Not_found ->
         h.data.(i) <- Cons(key, info, l);
-        h.size <- succ h.size;
-        if h.size > Array.length h.data lsl 1 then resize safehash h
+        h.size <- h.size + 1;
+        if h.size > Array.length h.data lsl 1 then resize key_index h
 
     let mem h key =
       let rec mem_in_bucket = function
@@ -271,9 +337,20 @@ module Make(H: HashedType): (S with type key = H.t) =
           false
       | Cons(k, d, rest) ->
           H.equal k key || mem_in_bucket rest in
-      mem_in_bucket h.data.((safehash key) mod (Array.length h.data))
+      mem_in_bucket h.data.(key_index h key)
 
     let iter = iter
     let fold = fold
     let length = length
+    let stats = stats
+  end
+
+module Make(H: HashedType): (S with type key = H.t) =
+  struct
+    include MakeSeeded(struct
+        type t = H.t
+        let equal = H.equal
+        let hash (seed: int) x = H.hash x
+      end)
+    let create sz = create ~seed:0 sz
   end

diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli
index 1bf175ad1f1503f8b798db95497fb8108dcfc460..98d03198f579b4da3c72e5b444226d20cea0da51 100644 (file)
--- a/stdlib/hashtbl.mli
+++ b/stdlib/hashtbl.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -25,12 +25,22 @@
 type ('a, 'b) t
 (** The type of hash tables from type ['a] to type ['b]. *)
 
-val create : int -> ('a, 'b) t
+val create : ?seed:int -> int -> ('a, 'b) t
 (** [Hashtbl.create n] creates a new, empty hash table, with
    initial size [n].  For best results, [n] should be on the
    order of the expected number of elements that will be in
    the table.  The table grows as needed, so [n] is just an
-   initial guess. *)
+   initial guess.
+
+   The optional [seed] parameter (an integer) can be given to
+   diversify the hash function used to access the returned table.
+   With high probability, hash tables created with different seeds
+   have different collision patterns.  In Web-facing applications
+   for instance, it is recommended to create hash tables with a
+   randomly-chosen seed.  This prevents a denial-of-service attack
+   whereas a malicious user sends input crafted to create many
+   collisions in the table and therefore slow the application down.
+   @before 4.00.0 the [seed] parameter was not present. *)
 
 val clear : ('a, 'b) t -> unit
 (** Empty a hash table. *)
@@ -94,9 +104,29 @@ val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
 
 val length : ('a, 'b) t -> int
 (** [Hashtbl.length tbl] returns the number of bindings in [tbl].
-   Multiple bindings are counted multiply, so [Hashtbl.length]
-   gives the number of times [Hashtbl.iter] calls its first argument. *)
-
+   It takes constant time.  Multiple bindings are counted once each, so
+   [Hashtbl.length] gives the number of times [Hashtbl.iter] calls its
+   first argument. *)
+
+type statistics = {
+  num_bindings: int;
+    (** Number of bindings present in the table.
+        Same value as returned by {!Hashtbl.length}. *)
+  num_buckets: int;
+    (** Number of buckets in the table. *)
+  max_bucket_length: int;
+    (** Maximal number of bindings per bucket. *)
+  bucket_histogram: int array
+    (** Histogram of bucket sizes.  This array [histo] has
+        length [hash_max_bucket_length + 1].  The value of
+        [histo.(i)] is the number of buckets whose size is [i]. *)
+}
+
+val stats : ('a, 'b) t -> statistics
+(** [Hashtbl.stats tbl] returns statistics about the table [tbl]:
+   number of buckets, size of the biggest bucket, distribution of
+   buckets by size.
+   @since 4.00.0 *)
 
 (** {6 Functorial interface} *)
 
@@ -113,12 +143,13 @@ module type HashedType =
           as computed by [hash].
           Examples: suitable ([equal], [hash]) pairs for arbitrary key
           types include
-          ([(=)], {!Hashtbl.hash}) for comparing objects by structure,
-          ([(fun x y -> compare x y = 0)], {!Hashtbl.hash})
-          for comparing objects by structure and handling {!Pervasives.nan}
-          correctly, and
-          ([(==)], {!Hashtbl.hash}) for comparing objects by addresses
-          (e.g. for cyclic keys). *)
+-         ([(=)], {!Hashtbl.hash}) for comparing objects by structure
+              (provided objects do not contain floats)
+-         ([(fun x y -> compare x y = 0)], {!Hashtbl.hash})
+              for comparing objects by structure
+              and handling {!Pervasives.nan} correctly
+-         ([(==)], {!Hashtbl.hash}) for comparing objects by physical
+              equality (e.g. for mutable or cyclic objects). *)
    end
 (** The input signature of the functor {!Hashtbl.Make}. *)
 
@@ -138,6 +169,7 @@ module type S =
     val iter : (key -> 'a -> unit) -> 'a t -> unit
     val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
     val length : 'a t -> int
+    val stats: 'a t -> statistics
   end
 (** The output signature of the functor {!Hashtbl.Make}. *)
 
@@ -151,27 +183,88 @@ module Make (H : HashedType) : S with type key = H.t
     specified in the functor argument [H] instead of generic
     equality and hashing. *)
 
+module type SeededHashedType =
+  sig
+    type t
+      (** The type of the hashtable keys. *)
+    val equal: t -> t -> bool
+      (** The equality predicate used to compare keys. *)
+    val hash: int -> t -> int
+      (** A seeded hashing function on keys.  The first argument is
+          the seed.  It must be the case that if [equal x y] is true,
+          then [hash seed x = hash seed y] for any value of [seed].
+          A suitable choice for [hash] is the function {!Hashtbl.seeded_hash}
+          below. *)
+  end
+(** The input signature of the functor {!Hashtbl.MakeSeeded}.
+    @since 4.00.0 *)
+
+module type SeededS =
+  sig
+    type key
+    type 'a t
+    val create : ?seed:int -> int -> 'a t
+    val clear : 'a t -> unit
+    val copy : 'a t -> 'a t
+    val add : 'a t -> key -> 'a -> unit
+    val remove : 'a t -> key -> unit
+    val find : 'a t -> key -> 'a
+    val find_all : 'a t -> key -> 'a list
+    val replace : 'a t -> key -> 'a -> unit
+    val mem : 'a t -> key -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val length : 'a t -> int
+    val stats: 'a t -> statistics
+  end
+(** The output signature of the functor {!Hashtbl.MakeSeeded}.
+    @since 4.00.0 *)
+
+module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t
+(** Functor building an implementation of the hashtable structure.
+    The functor [Hashtbl.MakeSeeded] returns a structure containing
+    a type [key] of keys and a type ['a t] of hash tables
+    associating data of type ['a] to keys of type [key].
+    The operations perform similarly to those of the generic
+    interface, but use the seeded hashing and equality functions
+    specified in the functor argument [H] instead of generic
+    equality and hashing.
+    @since 4.00.0 *)
+
 
-(** {6 The polymorphic hash primitive} *)
+(** {6 The polymorphic hash functions} *)
 
 
 val hash : 'a -> int
-(** [Hashtbl.hash x] associates a positive integer to any value of
+(** [Hashtbl.hash x] associates a nonnegative integer to any value of
    any type. It is guaranteed that
    if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y].
-   Moreover, [hash] always terminates, even on cyclic
-   structures. *)
-
-external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" "noalloc"
-(** [Hashtbl.hash_param n m x] computes a hash value for [x], with the
-   same properties as for [hash]. The two extra parameters [n] and
-   [m] give more precise control over hashing. Hashing performs a
-   depth-first, right-to-left traversal of the structure [x], stopping
-   after [n] meaningful nodes were encountered, or [m] nodes,
-   meaningful or not, were encountered. Meaningful nodes are: integers;
-   floating-point numbers; strings; characters; booleans; and constant
-   constructors. Larger values of [m] and [n] means that more
-   nodes are taken into account to compute the final hash
-   value, and therefore collisions are less likely to happen.
-   However, hashing takes longer. The parameters [m] and [n]
-   govern the tradeoff between accuracy and speed. *)
+   Moreover, [hash] always terminates, even on cyclic structures. *)
+
+val seeded_hash : int -> 'a -> int
+(** A variant of {!Hashtbl.hash} that is further parameterized by
+   an integer seed.
+   @since 4.00.0 *)
+
+val hash_param : int -> int -> 'a -> int
+(** [Hashtbl.hash_param meaningful total x] computes a hash value for [x],
+   with the same properties as for [hash]. The two extra integer
+   parameters [meaningful] and [total] give more precise control over
+   hashing. Hashing performs a breadth-first, left-to-right traversal
+   of the structure [x], stopping after [meaningful] meaningful nodes
+   were encountered, or [total] nodes (meaningful or not) were
+   encountered. Meaningful nodes are: integers; floating-point
+   numbers; strings; characters; booleans; and constant
+   constructors. Larger values of [meaningful] and [total] means that
+   more nodes are taken into account to compute the final hash value,
+   and therefore collisions are less likely to happen.  However,
+   hashing takes longer. The parameters [meaningful] and [total]
+   govern the tradeoff between accuracy and speed.  As default
+   choices, {!Hashtbl.hash} and {!Hashtbl.seeded_hash} take
+   [meaningful = 10] and [total = 100]. *)
+
+val seeded_hash_param : int -> int -> int -> 'a -> int
+(** A variant of {!Hashtbl.hash_param} that is further parameterized by
+   an integer seed.  Usage:
+   [Hashtbl.seeded_hash_param meaningful total seed x].
+   @since 4.00.0 *)

diff --git a/stdlib/header.c b/stdlib/header.c
index eda76325a60f50b211e1088fb9ec5a7e9f99b6ac..c82c7bc7f844d74e66cedcbb3b5b780ac62c473f 100644 (file)
--- a/stdlib/header.c
+++ b/stdlib/header.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/stdlib/headernt.c b/stdlib/headernt.c
index c8d23ee256fbb7132435b657ec0ba4cd4c82a75f..9972d5d5c11f0c199dd2adc0f05f951d2bdab552 100644 (file)
--- a/stdlib/headernt.c
+++ b/stdlib/headernt.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -26,7 +26,7 @@
 #pragma comment(lib , "kernel32")
 #endif
 
-char * default_runtime_name = "ocamlrun";
+char * default_runtime_name = RUNTIME_NAME;
 
 static
 #if _MSC_VER >= 1200

diff --git a/stdlib/int32.ml b/stdlib/int32.ml
index 64d525e88f5f4773be1da66b18ce026c01e72b4f..15237d7f481f6c6f15f62fb869a183e54dd40310 100644 (file)
--- a/stdlib/int32.ml
+++ b/stdlib/int32.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/int32.mli b/stdlib/int32.mli
index eeafb1a2fcf15792dd41de27c08a24e1068f0fd6..8bc7384ff2258c90b903192636a50853036164ab 100644 (file)
--- a/stdlib/int32.mli
+++ b/stdlib/int32.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/int64.ml b/stdlib/int64.ml
index e916fa4e0dde9dbf668c94d0c2e7edef981b717b..d8b1c3ca328b3293ce27b457d06356db4acca882 100644 (file)
--- a/stdlib/int64.ml
+++ b/stdlib/int64.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/int64.mli b/stdlib/int64.mli
index 3b641338e767a1e6600f612a8a752d4e93784e45..1f28f5c49be385e1cb2c9146428e9641ccdfbdc2 100644 (file)
--- a/stdlib/int64.mli
+++ b/stdlib/int64.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml
index b1a9cbbda3af9b092ab606cc0067e333b83776e0..6a114245e7e3fb8b220f35b1023126f8b56e37aa 100644 (file)
--- a/stdlib/lazy.ml
+++ b/stdlib/lazy.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -18,7 +18,7 @@
 
 (*
    WARNING: some purple magic is going on here.  Do not take this file
-   as an example of how to program in Objective Caml.
+   as an example of how to program in OCaml.
 *)
 
 
@@ -57,13 +57,13 @@ external force : 'a t -> 'a = "%lazy_force";;
 
 let force_val = CamlinternalLazy.force_val;;
 
-let lazy_from_fun (f : unit -> 'arg) =
+let from_fun (f : unit -> 'arg) =
   let x = Obj.new_block Obj.lazy_tag 1 in
   Obj.set_field x 0 (Obj.repr f);
   (Obj.obj x : 'arg t)
 ;;
 
-let lazy_from_val (v : 'arg) =
+let from_val (v : 'arg) =
   let t = Obj.tag (Obj.repr v) in
   if t = Obj.forward_tag || t = Obj.lazy_tag || t = Obj.double_tag then begin
     make_forward v
@@ -72,4 +72,10 @@ let lazy_from_val (v : 'arg) =
   end
 ;;
 
-let lazy_is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;;
+let is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;;
+
+let lazy_from_fun = from_fun;;
+
+let lazy_from_val = from_val;;
+
+let lazy_is_val = is_val;;

diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli
index 3b85717f143241c4d284f0798ebc61a04e7d91da..9d720d2bbc9464ce7f1a8840a94600e50d501abd 100644 (file)
--- a/stdlib/lazy.mli
+++ b/stdlib/lazy.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -42,8 +42,8 @@ type 'a t = 'a lazy_t;;
 
 exception Undefined;;
 
-external force : 'a t -> 'a = "%lazy_force";;
 (* val force : 'a t -> 'a ;; *)
+external force : 'a t -> 'a = "%lazy_force";;
 (** [force x] forces the suspension [x] and returns its result.
    If [x] has already been forced, [Lazy.force x] returns the
    same value again without recomputing it.  If it raised an exception,
@@ -62,15 +62,26 @@ val force_val : 'a t -> 'a;;
     whether [force_val x] raises the same exception or [Undefined].
 *)
 
+val from_fun : (unit -> 'a) -> 'a t;;
+(** [from_fun f] is the same as [lazy (f ())] but slightly more efficient.
+    @since 4.00.0 *)
+
+val from_val : 'a -> 'a t;;
+(** [from_val v] returns an already-forced suspension of [v].
+    This is for special purposes only and should not be confused with
+    [lazy (v)].
+    @since 4.00.0 *)
+
+val is_val : 'a t -> bool;;
+(** [is_val x] returns [true] if [x] has already been forced and
+    did not raise an exception.
+    @since 4.00.0 *)
+
 val lazy_from_fun : (unit -> 'a) -> 'a t;;
-(** [lazy_from_fun f] is the same as [lazy (f ())] but slightly more
-    efficient. *)
+(** @deprecated synonym for [from_fun]. *)
 
 val lazy_from_val : 'a -> 'a t;;
-(** [lazy_from_val v] returns an already-forced suspension of [v]
-    This is for special purposes only and should not be confused with
-    [lazy (v)]. *)
+(** @deprecated synonym for [from_val]. *)
 
 val lazy_is_val : 'a t -> bool;;
-(** [lazy_is_val x] returns [true] if [x] has already been forced and
-    did not raise an exception. *)
+(** @deprecated synonym for [is_val]. *)

diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml
index 9e01415265f3c46f243075ce4d3d232167e8006d..4d03ec088a64a8308976f7675059caab8bb674cf 100644 (file)
--- a/stdlib/lexing.ml
+++ b/stdlib/lexing.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli
index 2edb6c5df27eb02e6750f9f7acc195faf75616b4..a1a0690169d070ddb6954aefac1b79c255492ff7 100644 (file)
--- a/stdlib/lexing.mli
+++ b/stdlib/lexing.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,9 +26,12 @@ type position = {
 (** A value of type [position] describes a point in a source file.
    [pos_fname] is the file name; [pos_lnum] is the line number;
    [pos_bol] is the offset of the beginning of the line (number
-   of characters between the beginning of the file and the beginning
+   of characters between the beginning of the lexbuf and the beginning
    of the line); [pos_cnum] is the offset of the position (number of
-   characters between the beginning of the file and the position).
+   characters between the beginning of the lexbuf and the position).
+   The difference between [pos_cnum] and [pos_bol] is the character
+   offset within the line (i.e. the column number, assuming each
+   character is one column wide).
 
    See the documentation of type [lexbuf] for information about
    how the lexing engine will manage positions.
@@ -149,7 +152,7 @@ val flush_input : lexbuf -> unit
 (** {6  } *)
 
 (** The following definitions are used by the generated scanners only.
-   They are not intended to be used by user programs. *)
+   They are not intended to be used directly by user programs. *)
 
 val sub_lexeme : lexbuf -> int -> int -> string
 val sub_lexeme_opt : lexbuf -> int -> int -> string option

diff --git a/stdlib/list.ml b/stdlib/list.ml
index 8bb9e3fa6525d7f7a4d77c6c98fe1763bc274e37..aea05b4bf3650186c1c474377a307ee70f6103a6 100644 (file)
--- a/stdlib/list.ml
+++ b/stdlib/list.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -56,6 +56,12 @@ let rec map f = function
     [] -> []
   | a::l -> let r = f a in r :: map f l
 
+let rec mapi i f = function
+    [] -> []
+  | a::l -> let r = f i a in r :: mapi (i + 1) f l
+
+let mapi f l = mapi 0 f l
+
 let rev_map f l =
   let rec rmap_f accu = function
     | [] -> accu
@@ -68,6 +74,12 @@ let rec iter f = function
     [] -> ()
   | a::l -> f a; iter f l
 
+let rec iteri i f = function
+    [] -> ()
+  | a::l -> f i a; iteri (i + 1) f l
+
+let iteri f l = iteri 0 f l
+
 let rec fold_left f accu l =
   match l with
     [] -> accu

diff --git a/stdlib/list.mli b/stdlib/list.mli
index 8f89561907e92e183578a2460a4d4c431d08337d..855699d0510d45c1ec42dda5d0df676831364fd4 100644 (file)
--- a/stdlib/list.mli
+++ b/stdlib/list.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -75,11 +75,25 @@ val iter : ('a -> unit) -> 'a list -> unit
    [a1; ...; an]. It is equivalent to
    [begin f a1; f a2; ...; f an; () end]. *)
 
+val iteri : (int -> 'a -> unit) -> 'a list -> unit
+(** Same as {!List.iter}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.
+   @since 4.00.0
+*)
+
 val map : ('a -> 'b) -> 'a list -> 'b list
 (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
    and builds the list [[f a1; ...; f an]]
    with the results returned by [f].  Not tail-recursive. *)
 
+val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+(** Same as {!List.map}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.  Not tail-recursive.
+   @since 4.00.0
+*)
+
 val rev_map : ('a -> 'b) -> 'a list -> 'b list
 (** [List.rev_map f l] gives the same result as
    {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and

diff --git a/stdlib/listLabels.ml b/stdlib/listLabels.ml
index be7bddea367f780f059d5eb51ad2f5184251ae83..62b6e3768781a8cd3fe4843786e822955ba2dbf9 100644 (file)
--- a/stdlib/listLabels.ml
+++ b/stdlib/listLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)

diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli
index 1f6a4ead456c510060929ba2e927b8f8fb997b5a..b4b58045bf18a478b705de632ddeba9ef4bfa726 100644 (file)
--- a/stdlib/listLabels.mli
+++ b/stdlib/listLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -75,11 +75,25 @@ val iter : f:('a -> unit) -> 'a list -> unit
    [a1; ...; an]. It is equivalent to
    [begin f a1; f a2; ...; f an; () end]. *)
 
+val iteri : f:(int -> 'a -> unit) -> 'a list -> unit
+(** Same as {!List.iter}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.
+   @since 4.00.0
+*)
+
 val map : f:('a -> 'b) -> 'a list -> 'b list
 (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
    and builds the list [[f a1; ...; f an]]
    with the results returned by [f].  Not tail-recursive. *)
 
+val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list
+(** Same as {!List.map}, but the function is applied to the index of
+   the element as first argument (counting from 0), and the element
+   itself as second argument.
+   @since 4.00.0
+*)
+
 val rev_map : f:('a -> 'b) -> 'a list -> 'b list
 (** [List.rev_map f l] gives the same result as
    {!ListLabels.rev}[ (]{!ListLabels.map}[ f l)], but is tail-recursive and

diff --git a/stdlib/map.ml b/stdlib/map.ml
index 3d9597aa0efbc892418f5abd2526c97636ac3d2f..519ef824e70e540a388f05a73b2d65c079300234 100644 (file)
--- a/stdlib/map.ml
+++ b/stdlib/map.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -200,27 +200,31 @@ module Make(Ord: OrderedType) = struct
         Empty -> false
       | Node(l, v, d, r, _) -> p v d || exists p l || exists p r
 
-    let filter p s =
-      let rec filt accu = function
-        | Empty -> accu
-        | Node(l, v, d, r, _) ->
-            filt (filt (if p v d then add v d accu else accu) l) r in
-      filt Empty s
+    (* Beware: those two functions assume that the added k is *strictly*
+       smaller (or bigger) than all the present keys in the tree; it
+       does not test for equality with the current min (or max) key.
 
-    let partition p s =
-      let rec part (t, f as accu) = function
-        | Empty -> accu
-        | Node(l, v, d, r, _) ->
-            part (part (if p v d then (add v d t, f) else (t, add v d f)) l) r in
-      part (Empty, Empty) s
+       Indeed, they are only used during the "join" operation which
+       respects this precondition.
+    *)
+
+    let rec add_min_binding k v = function
+      | Empty -> singleton k v
+      | Node (l, x, d, r, h) ->
+        bal (add_min_binding k v l) x d r
+
+    let rec add_max_binding k v = function
+      | Empty -> singleton k v
+      | Node (l, x, d, r, h) ->
+        bal l x d (add_max_binding k v r)
 
     (* Same as create and bal, but no assumptions are made on the
        relative heights of l and r. *)
 
     let rec join l v d r =
       match (l, r) with
-        (Empty, _) -> add v d r
-      | (_, Empty) -> add v d l
+        (Empty, _) -> add_min_binding v d r
+      | (_, Empty) -> add_max_binding v d l
       | (Node(ll, lv, ld, lr, lh), Node(rl, rv, rd, rr, rh)) ->
           if lh > rh + 2 then bal ll lv ld (join lr v d r) else
           if rh > lh + 2 then bal (join l v d rl) rv rd rr else
@@ -266,6 +270,20 @@ module Make(Ord: OrderedType) = struct
       | _ ->
           assert false
 
+    let rec filter p = function
+        Empty -> Empty
+      | Node(l, v, d, r, _) ->
+          let l' = filter p l and r' = filter p r in
+          if p v d then join l' v d r' else concat l' r'
+
+    let rec partition p = function
+        Empty -> (Empty, Empty)
+      | Node(l, v, d, r, _) ->
+          let (lt, lf) = partition p l and (rt, rf) = partition p r in
+          if p v d
+          then (join lt v d rt, concat lf rf)
+          else (concat lt rt, join lf v d rf)
+
     type 'a enumeration = End | More of key * 'a * 'a t * 'a enumeration
 
     let rec cons_enum m e =

diff --git a/stdlib/map.mli b/stdlib/map.mli
index b025b8c0a62bd7da78a083e52f78e0a13d54b656..a6374dbdf6745467207e36bc79c4b1ab6c35b2d1 100644 (file)
--- a/stdlib/map.mli
+++ b/stdlib/map.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml
index 0410a23e991d76fdca011f5695d8ecc1a55fa835..638f05434ab8b2806ab3ba9344f718c28a86b3c7 100644 (file)
--- a/stdlib/marshal.ml
+++ b/stdlib/marshal.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -16,6 +16,7 @@
 type extern_flags =
     No_sharing
   | Closures
+(* note: this type definition is used in 'byterun/debugger.c' *)
 
 external to_channel: out_channel -> 'a -> extern_flags list -> unit
     = "caml_output_value"

diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli
index ac0775bb16872127b83a07cd25291e33d06cea4a..86e1ebd1990198dc37a7f56d8fcf0115b2ebf6d6 100644 (file)
--- a/stdlib/marshal.mli
+++ b/stdlib/marshal.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,14 +20,14 @@
    sent over a pipe or network connection.  The bytes can then
    be read back later, possibly in another process, and decoded back
    into a data structure. The format for the byte sequences
-   is compatible across all machines for a given version of Objective Caml.
+   is compatible across all machines for a given version of OCaml.
 
    Warning: marshaling is currently not type-safe. The type
    of marshaled data is not transmitted along the value of the data,
    making it impossible to check that the data read back possesses the
    type expected by the context. In particular, the result type of
    the [Marshal.from_*] functions is given as ['a], but this is
-   misleading: the returned Caml value does not possess type ['a]
+   misleading: the returned OCaml value does not possess type ['a]
    for all ['a]; it has one, unique type which cannot be determined
    at compile-type.  The programmer should explicitly give the expected
    type of the returned value, using the following syntax:
@@ -115,7 +115,7 @@ val header_size : int
    {!Marshal.data_size}[ buff ofs] is the size, in characters,
    of the data part, assuming a valid header is stored in
    [buff] starting at position [ofs].
-   Finally, {!Marshal.total_size}[ buff ofs] is the total size,
+   Finally, {!Marshal.total_size} [buff ofs] is the total size,
    in characters, of the marshaled value.
    Both {!Marshal.data_size} and {!Marshal.total_size} raise [Failure]
    if [buff], [ofs] does not contain a valid header.

diff --git a/stdlib/moreLabels.ml b/stdlib/moreLabels.ml
index f6cfddabc6687eb33be0dcd8f8d33242a5c58754..3fda7a5b32272bec01f5379d3f411d079b1a2bce 100644 (file)
--- a/stdlib/moreLabels.ml
+++ b/stdlib/moreLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)

diff --git a/stdlib/moreLabels.mli b/stdlib/moreLabels.mli
index 55c773347fe36418de3bacf7c48dd2a9c2680671..c2691cba5f232b1b568955ec4bd68ef47c693b13 100644 (file)
--- a/stdlib/moreLabels.mli
+++ b/stdlib/moreLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
@@ -19,13 +19,13 @@
    {!Map} and {!Set} modules.
 
    They only differ by their labels. They are provided to help
-   porting from previous versions of Objective Caml.
+   porting from previous versions of OCaml.
    The contents of this module are subject to change.
 *)
 
 module Hashtbl : sig
   type ('a, 'b) t = ('a, 'b) Hashtbl.t
-  val create : int -> ('a, 'b) t
+  val create : ?seed:int -> int -> ('a, 'b) t
   val clear : ('a, 'b) t -> unit
   val add : ('a, 'b) t -> key:'a -> data:'b -> unit
   val copy : ('a, 'b) t -> ('a, 'b) t
@@ -39,7 +39,10 @@ module Hashtbl : sig
       f:(key:'a -> data:'b -> 'c -> 'c) ->
         ('a, 'b) t -> init:'c -> 'c
   val length : ('a, 'b) t -> int
+  type statistics = Hashtbl.statistics
+  val stats : ('a, 'b) t -> statistics
   module type HashedType = Hashtbl.HashedType
+  module type SeededHashedType = Hashtbl.SeededHashedType
   module type S =
     sig
       type key
@@ -58,11 +61,34 @@ module Hashtbl : sig
           f:(key:key -> data:'a -> 'b -> 'b) ->
           'a t -> init:'b -> 'b
       val length : 'a t -> int
+      val stats: 'a t -> statistics
+    end
+  module type SeededS =
+    sig
+      type key
+      and 'a t
+      val create : ?seed:int -> int -> 'a t
+      val clear : 'a t -> unit
+      val copy : 'a t -> 'a t
+      val add : 'a t -> key:key -> data:'a -> unit
+      val remove : 'a t -> key -> unit
+      val find : 'a t -> key -> 'a
+      val find_all : 'a t -> key -> 'a list
+      val replace : 'a t -> key:key -> data:'a -> unit
+      val mem : 'a t -> key -> bool
+      val iter : f:(key:key -> data:'a -> unit) -> 'a t -> unit
+      val fold :
+          f:(key:key -> data:'a -> 'b -> 'b) ->
+          'a t -> init:'b -> 'b
+      val length : 'a t -> int
+      val stats: 'a t -> statistics
     end
   module Make : functor (H : HashedType) -> S with type key = H.t
+  module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t
   val hash : 'a -> int
-  external hash_param : int -> int -> 'a -> int
-      = "caml_hash_univ_param" "noalloc"
+  val seeded_hash : int -> 'a -> int
+  val hash_param : int -> int -> 'a -> int
+  val seeded_hash_param : int -> int -> int -> 'a -> int
 end
 
 module Map : sig

diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml
index 934784361990e6b085cb29b63bf13a1db1dfa7dc..4bba76d566d67aec2341c33bf4234d1ce7ab3318 100644 (file)
--- a/stdlib/nativeint.ml
+++ b/stdlib/nativeint.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli
index ff499a26f8abd78d5ad81aa68ed40e3d3c572dab..7de11ea00d4908589eb88dfa8ec31021185bec0e 100644 (file)
--- a/stdlib/nativeint.mli
+++ b/stdlib/nativeint.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/obj.ml b/stdlib/obj.ml
index c16b511560759d244dbd3fb8c1301f14731e0744..96de162f6c5d2b7cef5a4aa9fa2ffbdaeaca837f 100644 (file)
--- a/stdlib/obj.ml
+++ b/stdlib/obj.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/obj.mli b/stdlib/obj.mli
index 57df04917d9ee3ded449aca810b53d1c817bca6c..9b66723b2a75da143648e81e25ea92c9f95cd7f5 100644 (file)
--- a/stdlib/obj.mli
+++ b/stdlib/obj.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/oo.ml b/stdlib/oo.ml
index c9ec64ae44dccaa51f195f3effecdaa5f18487ce..40c8ae6e4ab744888050cc6273f084dd1ca9dcc0 100644 (file)
--- a/stdlib/oo.ml
+++ b/stdlib/oo.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/oo.mli b/stdlib/oo.mli
index b3111ce85704d8dac8456e1a84d9d502700c0e4d..2a9eb2320937aa33b64f5e75f93aabe2ca6ca0d5 100644 (file)
--- a/stdlib/oo.mli
+++ b/stdlib/oo.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -17,13 +17,22 @@
 
 val copy : (< .. > as 'a) -> 'a
 (** [Oo.copy o] returns a copy of object [o], that is a fresh
-   object with the same methods and instance variables as [o]  *)
+   object with the same methods and instance variables as [o]. *)
 
 external id : < .. > -> int = "%field1"
 (** Return an integer identifying this object, unique for
-    the current execution of the program. *)
+    the current execution of the program. The generic comparison
+    and hashing functions are based on this integer. When an object
+    is obtained by unmarshaling, the id is refreshed, and thus
+    different from the original object. As a consequence, the internal
+    invariants of data structures such as hash table or sets containing
+    objects are broken after unmarshaling the data structures.
+  *)
 
 (**/**)
+
+(* The following is for system use only. Do not call directly. *)
+
 (** For internal use (CamlIDL) *)
 val new_method : string -> CamlinternalOO.tag
 val public_method_label : string -> CamlinternalOO.tag

diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml
index 5d53c741323a35204a4ac3360d30950188c4250c..55a8f53aab48a028f2175c5e7e4090cbda2ae685 100644 (file)
--- a/stdlib/parsing.ml
+++ b/stdlib/parsing.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli
index 03721ba30875ce5cfd9dcf952daf6e723ba18683..f488245992af588f9d5f6170f1d9bee49ed4a019 100644 (file)
--- a/stdlib/parsing.mli
+++ b/stdlib/parsing.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -74,7 +74,7 @@ val set_trace: bool -> bool
 (** {6  } *)
 
 (** The following definitions are used by the generated parsers only.
-   They are not intended to be used by user programs. *)
+   They are not intended to be used directly by user programs. *)
 
 type parser_env
 

diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml
index 22dfa8fc2507ca3d9b76827b86fd4ca8e901612e..17a1a9c1a8c6bb66658e8949334ea7bf91b150f2 100644 (file)
--- a/stdlib/pervasives.ml
+++ b/stdlib/pervasives.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,63 +26,63 @@ exception Exit
 
 (* Comparisons *)
 
-external (=) : 'a -> 'a -> bool = "%equal"
-external (<>) : 'a -> 'a -> bool = "%notequal"
-external (<) : 'a -> 'a -> bool = "%lessthan"
-external (>) : 'a -> 'a -> bool = "%greaterthan"
-external (<=) : 'a -> 'a -> bool = "%lessequal"
-external (>=) : 'a -> 'a -> bool = "%greaterequal"
-external compare: 'a -> 'a -> int = "%compare"
+external ( = ) : 'a -> 'a -> bool = "%equal"
+external ( <> ) : 'a -> 'a -> bool = "%notequal"
+external ( < ) : 'a -> 'a -> bool = "%lessthan"
+external ( > ) : 'a -> 'a -> bool = "%greaterthan"
+external ( <= ) : 'a -> 'a -> bool = "%lessequal"
+external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
+external compare : 'a -> 'a -> int = "%compare"
 
 let min x y = if x <= y then x else y
 let max x y = if x >= y then x else y
 
-external (==) : 'a -> 'a -> bool = "%eq"
-external (!=) : 'a -> 'a -> bool = "%noteq"
+external ( == ) : 'a -> 'a -> bool = "%eq"
+external ( != ) : 'a -> 'a -> bool = "%noteq"
 
 (* Boolean operations *)
 
 external not : bool -> bool = "%boolnot"
-external (&) : bool -> bool -> bool = "%sequand"
-external (&&) : bool -> bool -> bool = "%sequand"
-external (or) : bool -> bool -> bool = "%sequor"
-external (||) : bool -> bool -> bool = "%sequor"
+external ( & ) : bool -> bool -> bool = "%sequand"
+external ( && ) : bool -> bool -> bool = "%sequand"
+external ( or ) : bool -> bool -> bool = "%sequor"
+external ( || ) : bool -> bool -> bool = "%sequor"
 
 (* Integer operations *)
 
-external (~-) : int -> int = "%negint"
-external (~+) : int -> int = "%identity"
+external ( ~- ) : int -> int = "%negint"
+external ( ~+ ) : int -> int = "%identity"
 external succ : int -> int = "%succint"
 external pred : int -> int = "%predint"
-external (+) : int -> int -> int = "%addint"
-external (-) : int -> int -> int = "%subint"
-external ( * ) : int -> int -> int = "%mulint"
-external (/) : int -> int -> int = "%divint"
-external (mod) : int -> int -> int = "%modint"
+external ( + ) : int -> int -> int = "%addint"
+external ( - ) : int -> int -> int = "%subint"
+external ( *  ) : int -> int -> int = "%mulint"
+external ( / ) : int -> int -> int = "%divint"
+external ( mod ) : int -> int -> int = "%modint"
 
 let abs x = if x >= 0 then x else -x
 
-external (land) : int -> int -> int = "%andint"
-external (lor) : int -> int -> int = "%orint"
-external (lxor) : int -> int -> int = "%xorint"
+external ( land ) : int -> int -> int = "%andint"
+external ( lor ) : int -> int -> int = "%orint"
+external ( lxor ) : int -> int -> int = "%xorint"
 
 let lnot x = x lxor (-1)
 
-external (lsl) : int -> int -> int = "%lslint"
-external (lsr) : int -> int -> int = "%lsrint"
-external (asr) : int -> int -> int = "%asrint"
+external ( lsl ) : int -> int -> int = "%lslint"
+external ( lsr ) : int -> int -> int = "%lsrint"
+external ( asr ) : int -> int -> int = "%asrint"
 
 let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62)
 let max_int = min_int - 1
 
 (* Floating-point operations *)
 
-external (~-.) : float -> float = "%negfloat"
-external (~+.) : float -> float = "%identity"
-external (+.) : float -> float -> float = "%addfloat"
-external (-.) : float -> float -> float = "%subfloat"
+external ( ~-. ) : float -> float = "%negfloat"
+external ( ~+. ) : float -> float = "%identity"
+external ( +. ) : float -> float -> float = "%addfloat"
+external ( -. ) : float -> float -> float = "%subfloat"
 external ( *. ) : float -> float -> float = "%mulfloat"
-external (/.) : float -> float -> float = "%divfloat"
+external ( /. ) : float -> float -> float = "%divfloat"
 external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float"
 external exp : float -> float = "caml_exp_float" "exp" "float"
 external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float"
@@ -90,6 +90,8 @@ external acos : float -> float = "caml_acos_float" "acos" "float"
 external asin : float -> float = "caml_asin_float" "asin" "float"
 external atan : float -> float = "caml_atan_float" "atan" "float"
 external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
+external hypot : float -> float -> float
+               = "caml_hypot_float" "caml_hypot" "float"
 external cos : float -> float = "caml_cos_float" "cos" "float"
 external cosh : float -> float = "caml_cosh_float" "cosh" "float"
 external log : float -> float = "caml_log_float" "log" "float"
@@ -103,6 +105,8 @@ external tanh : float -> float = "caml_tanh_float" "tanh" "float"
 external ceil : float -> float = "caml_ceil_float" "ceil" "float"
 external floor : float -> float = "caml_floor_float" "floor" "float"
 external abs_float : float -> float = "%absfloat"
+external copysign : float -> float -> float
+                  = "caml_copysign_float" "caml_copysign" "float"
 external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
 external frexp : float -> float * int = "caml_frexp_float"
 external ldexp : float -> int -> float = "caml_ldexp_float"
@@ -131,16 +135,16 @@ type fpclass =
   | FP_zero
   | FP_infinite
   | FP_nan
-external classify_float: float -> fpclass = "caml_classify_float"
+external classify_float : float -> fpclass = "caml_classify_float"
 
 (* String operations -- more in module String *)
 
 external string_length : string -> int = "%string_length"
-external string_create: int -> string = "caml_create_string"
+external string_create : int -> string = "caml_create_string"
 external string_blit : string -> int -> string -> int -> int -> unit
                      = "caml_blit_string" "noalloc"
 
-let (^) s1 s2 =
+let ( ^ ) s1 s2 =
   let l1 = string_length s1 and l2 = string_length s2 in
   let s = string_create (l1 + l2) in
   string_blit s1 0 s 0 l1;
@@ -165,8 +169,8 @@ external snd : 'a * 'b -> 'b = "%field1"
 
 (* String conversion functions *)
 
-external format_int: string -> int -> string = "caml_format_int"
-external format_float: string -> float -> string = "caml_format_float"
+external format_int : string -> int -> string = "caml_format_int"
+external format_float : string -> float -> string = "caml_format_float"
 
 let string_of_bool b =
   if b then "true" else "false"
@@ -189,7 +193,7 @@ let valid_float_lexem s =
   let rec loop i =
     if i >= l then s ^ "." else
     match s.[i] with
-    | '0' .. '9' | '-' -> loop (i+1)
+    | '0' .. '9' | '-' -> loop (i + 1)
     | _ -> s
   in
   loop 0
@@ -201,7 +205,7 @@ external float_of_string : string -> float = "caml_float_of_string"
 
 (* List operations -- more in module List *)
 
-let rec (@) l1 l2 =
+let rec ( @ ) l1 l2 =
   match l1 with
     [] -> l2
   | hd :: tl -> hd :: (tl @ l2)
@@ -211,8 +215,9 @@ let rec (@) l1 l2 =
 type in_channel
 type out_channel
 
-external open_descriptor_out: int -> out_channel = "caml_ml_open_descriptor_out"
-external open_descriptor_in: int -> in_channel = "caml_ml_open_descriptor_in"
+external open_descriptor_out : int -> out_channel
+                             = "caml_ml_open_descriptor_out"
+external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in"
 
 let stdin = open_descriptor_in 0
 let stdout = open_descriptor_out 1
@@ -225,7 +230,7 @@ type open_flag =
   | Open_creat | Open_trunc | Open_excl
   | Open_binary | Open_text | Open_nonblock
 
-external open_desc: string -> open_flag list -> int -> int = "caml_sys_open"
+external open_desc : string -> open_flag list -> int -> int = "caml_sys_open"
 
 let open_out_gen mode perm name =
   open_descriptor_out(open_desc name mode perm)
@@ -244,7 +249,7 @@ external out_channels_list : unit -> out_channel list
 let flush_all () =
   let rec iter = function
       [] -> ()
-    | a::l -> (try flush a with _ -> ()); iter l
+    | a :: l -> (try flush a with _ -> ()); iter l
   in iter (out_channels_list ())
 
 external unsafe_output : out_channel -> string -> int -> int -> unit
@@ -304,7 +309,7 @@ let rec unsafe_really_input ic s ofs len =
     let r = unsafe_input ic s ofs len in
     if r = 0
     then raise End_of_file
-    else unsafe_really_input ic s (ofs+r) (len-r)
+    else unsafe_really_input ic s (ofs + r) (len - r)
   end
 
 let really_input ic s ofs len =
@@ -328,8 +333,8 @@ let input_line chan =
         [] -> raise End_of_file
       | _  -> build_result (string_create len) len accu
     end else if n > 0 then begin          (* n > 0: newline found in buffer *)
-      let res = string_create (n-1) in
-      ignore (unsafe_input chan res 0 (n-1));
+      let res = string_create (n - 1) in
+      ignore (unsafe_input chan res 0 (n - 1));
       ignore (input_char chan);           (* skip the newline *)
       match accu with
         [] -> res
@@ -394,12 +399,12 @@ module LargeFile =
 
 (* References *)
 
-type 'a ref = { mutable contents: 'a }
-external ref: 'a -> 'a ref = "%makemutable"
-external (!): 'a ref -> 'a = "%field0"
-external (:=): 'a ref -> 'a -> unit = "%setfield0"
-external incr: int ref -> unit = "%incr"
-external decr: int ref -> unit = "%decr"
+type 'a ref = { mutable contents : 'a }
+external ref : 'a -> 'a ref = "%makemutable"
+external ( ! ) : 'a ref -> 'a = "%field0"
+external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
+external incr : int ref -> unit = "%incr"
+external decr : int ref -> unit = "%decr"
 
 (* Formats *)
 type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6

diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli
index d741313dea9266561175a32fbdbd620881b59168..bf19b2aeac9413a94bbd48d4ae08ed0d619adaf9 100644 (file)
--- a/stdlib/pervasives.mli
+++ b/stdlib/pervasives.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -52,24 +52,24 @@ external ( = ) : 'a -> 'a -> bool = "%equal"
    Equality between cyclic data structures may not terminate. *)
 
 external ( <> ) : 'a -> 'a -> bool = "%notequal"
-(** Negation of {!Pervasives.(=)}. *)
+(** Negation of {!Pervasives.( = )}. *)
 
 external ( < ) : 'a -> 'a -> bool = "%lessthan"
-(** See {!Pervasives.(>=)}. *)
+(** See {!Pervasives.( >= )}. *)
 
 external ( > ) : 'a -> 'a -> bool = "%greaterthan"
-(** See {!Pervasives.(>=)}. *)
+(** See {!Pervasives.( >= )}. *)
 
 external ( <= ) : 'a -> 'a -> bool = "%lessequal"
-(** See {!Pervasives.(>=)}. *)
+(** See {!Pervasives.( >= )}. *)
 
 external ( >= ) : 'a -> 'a -> bool = "%greaterequal"
 (** Structural ordering functions. These functions coincide with
    the usual orderings over integers, characters, strings
    and floating-point numbers, and extend them to a
    total ordering over all types.
-   The ordering is compatible with [(=)]. As in the case
-   of [(=)], mutable structures are compared by contents.
+   The ordering is compatible with [( = )]. As in the case
+   of [( = )], mutable structures are compared by contents.
    Comparison between functional values raises [Invalid_argument].
    Comparison between cyclic structures may not terminate. *)
 
@@ -108,12 +108,12 @@ external ( == ) : 'a -> 'a -> bool = "%eq"
    mutable fields and objects with mutable instance variables,
    [e1 == e2] is true if and only if physical modification of [e1]
    also affects [e2].
-   On non-mutable types, the behavior of [(==)] is
+   On non-mutable types, the behavior of [( == )] is
    implementation-dependent; however, it is guaranteed that
    [e1 == e2] implies [compare e1 e2 = 0]. *)
 
 external ( != ) : 'a -> 'a -> bool = "%noteq"
-(** Negation of {!Pervasives.(==)}. *)
+(** Negation of {!Pervasives.( == )}. *)
 
 
 (** {6 Boolean operations} *)
@@ -229,7 +229,7 @@ external ( asr ) : int -> int -> int = "%asrint"
 
 (** {6 Floating-point arithmetic}
 
-   Caml's floating-point numbers follow the
+   OCaml's floating-point numbers follow the
    IEEE 754 standard, using double precision (64 bits) numbers.
    Floating-point operations never raise an exception on overflow,
    underflow, division by zero, etc.  Instead, special IEEE numbers
@@ -314,6 +314,14 @@ external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float"
     and [y] are used to determine the quadrant of the result.
     Result is in radians and is between [-pi] and [pi]. *)
 
+external hypot : float -> float -> float
+               = "caml_hypot_float" "caml_hypot" "float"
+(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length
+  of the hypotenuse of a right-angled triangle with sides of length
+  [x] and [y], or, equivalently, the distance of the point [(x,y)]
+  to origin.
+  @since 4.00.0  *)
+
 external cosh : float -> float = "caml_cosh_float" "cosh" "float"
 (** Hyperbolic cosine.  Argument is in radians. *)
 
@@ -337,6 +345,14 @@ external floor : float -> float = "caml_floor_float" "floor" "float"
 external abs_float : float -> float = "%absfloat"
 (** [abs_float f] returns the absolute value of [f]. *)
 
+external copysign : float -> float -> float
+                  = "caml_copysign_float" "caml_copysign" "float"
+(** [copysign x y] returns a float whose absolute value is that of [x]
+  and whose sign is that of [y].  If [x] is [nan], returns [nan].
+  If [y] is [nan], returns either [x] or [-. x], but it is not
+  specified which.
+  @since 4.00.0  *)
+
 external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float"
 (** [mod_float a b] returns the remainder of [a] with respect to
    [b].  The returned value is [a -. n *. b], where [n]
@@ -445,7 +461,9 @@ external ignore : 'a -> unit = "%ignore"
 (** {6 String conversion functions} *)
 
 val string_of_bool : bool -> string
-(** Return the string representation of a boolean. *)
+(** Return the string representation of a boolean. As the returned values
+   may be shared, the user should not modify them directly.
+*)
 
 val bool_of_string : string -> bool
 (** Convert the given string to a boolean.
@@ -642,7 +660,7 @@ val output_binary_int : out_channel -> int -> unit
    The given integer is taken modulo 2{^32}.
    The only reliable way to read it back is through the
    {!Pervasives.input_binary_int} function. The format is compatible across
-   all machines for a given version of Objective Caml. *)
+   all machines for a given version of OCaml. *)
 
 val output_value : out_channel -> 'a -> unit
 (** Write the representation of a structured value of any type
@@ -855,16 +873,16 @@ external decr : int ref -> unit = "%decr"
 (** Format strings have a general and highly polymorphic type
     [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in.
     The two simplified types, [format] and [format4] below are
-    included for backward compatibility with earlier releases of Objective
-    Caml.
+    included for backward compatibility with earlier releases of OCaml.
     ['a] is the type of the parameters of the format,
     ['b] is the type of the first argument given to
          [%a] and [%t] printing functions,
-    ['c] is the type of the argument transmitted to the first argument of
-         "kprintf"-style functions,
-    ['d] is the result type for the "scanf"-style functions,
-    ['e] is the type of the receiver function for the "scanf"-style functions,
-    ['f] is the result type for the "printf"-style function.
+    ['c] is the type of the result of the [%a] and [%t] functions, and
+         also the type of the argument transmitted to the first argument
+         of [kprintf]-style functions,
+    ['d] is the result type for the [scanf]-style functions,
+    ['e] is the type of the receiver function for the [scanf]-style functions,
+    ['f] is the result type for the [printf]-style function.
  *)
 type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
 
@@ -893,7 +911,7 @@ val exit : int -> 'a
 (** Terminate the process, returning the given status code
    to the operating system: usually 0 to indicate no errors,
    and a small positive integer to indicate failure.
-   All open output channels are flushed with flush_all.
+   All open output channels are flushed with [flush_all].
    An implicit [exit 0] is performed each time a program
    terminates normally.  An implicit [exit 2] is performed if the program
    terminates early because of an uncaught exception. *)
@@ -908,8 +926,7 @@ val at_exit : (unit -> unit) -> unit
 
 (**/**)
 
-
-(** {6 For system use only, not for the casual user} *)
+(* The following is for system use only. Do not call directly. *)
 
 val valid_float_lexem : string -> string
 

diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml
index 9e435c590b2b552fc8d0c845d7e571d97d6e1493..062decb857908cfdbe528054785a239f6668f1ef 100644 (file)
--- a/stdlib/printexc.ml
+++ b/stdlib/printexc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -56,6 +56,8 @@ let to_string x =
             sprintf locfmt file line char (char+5) "Pattern matching failed"
         | Assert_failure(file, line, char) ->
             sprintf locfmt file line char (char+6) "Assertion failed"
+        | Undefined_recursive_module(file, line, char) ->
+            sprintf locfmt file line char (char+6) "Undefined recursive module"
         | _ ->
             let x = Obj.repr x in
             let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in

diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli
index 71a6af553302c91e4141ba6387b99821cffc336f..93ee5d6d1a9ee15ad4488aee9b7457e73453935a 100644 (file)
--- a/stdlib/printexc.mli
+++ b/stdlib/printexc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -77,5 +77,10 @@ val register_printer: (exn -> string option) -> unit
     in the reverse order of their registrations, until a printer returns
     a [Some s] value (if no such printer exists, the runtime will use a
     generic printer).
+
+    When using this mechanism, one should be aware that an exception backtrace
+    is attached to the thread that saw it raised, rather than to the exception
+    itself. Practically, it means that the code related to [fn] should not use
+    the backtrace if it has itself raised an exception before.
     @since 3.11.2
 *)

diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index 13f16dd69fcde2a4c0294ed3e5c1cac088f8f9a4..c55c64d3673fc33e0f3e1d7dd956c7e747e94504 100644 (file)
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -217,7 +217,7 @@ let iter_on_format_args fmt add_conv add_char =
   and scan_conv skip i =
     if i > lim then incomplete_format fmt else
     match Sformat.unsafe_get fmt i with
-    | '%' | '!' | ',' -> succ i
+    | '%' | '@' | '!' | ',' -> succ i
     | 's' | 'S' | '[' -> add_conv skip i 's'
     | 'c' | 'C' -> add_conv skip i 'c'
     | 'd' | 'i' |'o' | 'u' | 'x' | 'X' | 'N' -> add_conv skip i 'i'
@@ -230,7 +230,7 @@ let iter_on_format_args fmt add_conv add_char =
         match Sformat.get fmt j with
         | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
           add_char (add_conv skip i conv) 'i'
-        | c -> add_conv skip i 'i' end
+        | _ -> add_conv skip i 'i' end
     | '{' as conv ->
       (* Just get a regular argument, skipping the specification. *)
       let i = add_conv skip i conv in
@@ -301,7 +301,7 @@ let ac_of_format fmt =
     (* Just finishing a meta format: no additional argument to record. *)
     if c <> ')' && c <> '}' then incr_ac skip c;
     succ i
-  and add_char i c = succ i in
+  and add_char i _ = succ i in
 
   iter_on_format_args fmt add_conv add_char;
   ac
@@ -391,9 +391,9 @@ type positional_specification =
    with $n$ being the {\em value} of the integer argument defining [*]; we
    clearly cannot statically guess the value of this parameter in the general
    case. Put it another way: this means type dependency, which is completely
-   out of scope of the Caml type algebra. *)
+   out of scope of the OCaml type algebra. *)
 
-let scan_positional_spec fmt got_spec n i =
+let scan_positional_spec fmt got_spec i =
   match Sformat.unsafe_get fmt i with
   | '0'..'9' as d ->
     let rec get_int_literal accu j =
@@ -430,7 +430,7 @@ let get_index spec n =
   | Spec_index p -> p
 ;;
 
-(* Format a float argument as a valid Caml lexeme. *)
+(* Format a float argument as a valid OCaml lexeme. *)
 let format_float_lexeme =
 
   (* To be revised: this procedure should be a unique loop that performs the
@@ -443,7 +443,7 @@ let format_float_lexeme =
   let make_valid_float_lexeme s =
     (* Check if s is already a valid lexeme:
        in this case do nothing,
-       otherwise turn s into a valid Caml lexeme. *)
+       otherwise turn s into a valid OCaml lexeme. *)
     let l = String.length s in
     let rec valid_float_loop i =
       if i >= l then s ^ "." else
@@ -490,7 +490,7 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
 
   let rec scan_positional n widths i =
     let got_spec spec i = scan_flags spec n widths i in
-    scan_positional_spec fmt got_spec n i
+    scan_positional_spec fmt got_spec i
 
   and scan_flags spec n widths i =
     match Sformat.unsafe_get fmt i with
@@ -498,15 +498,17 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
       let got_spec wspec i =
         let (width : int) = get_arg wspec n in
         scan_flags spec (next_index wspec n) (width :: widths) i in
-      scan_positional_spec fmt got_spec n (succ i)
+      scan_positional_spec fmt got_spec (succ i)
     | '0'..'9'
     | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i)
     | _ -> scan_conv spec n widths i
 
   and scan_conv spec n widths i =
     match Sformat.unsafe_get fmt i with
-    | '%' ->
-      cont_s n "%" (succ i)
+    | '%' | '@' as c ->
+      cont_s n (String.make 1 c) (succ i)
+    | '!' -> cont_f n (succ i)
+    | ',' -> cont_s n "" (succ i)
     | 's' | 'S' as conv ->
       let (x : string) = get_arg spec n in
       let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in
@@ -515,6 +517,8 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
         if i = succ pos then x else
         format_string (extract_format fmt pos i widths) x in
       cont_s (next_index spec n) s (succ i)
+    | '[' as conv ->
+      bad_conversion_format fmt i conv
     | 'c' | 'C' as conv ->
       let (x : char) = get_arg spec n in
       let s =
@@ -546,6 +550,8 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
       let n = Sformat.succ_index (get_index spec n) in
       let arg = get_arg Spec_none n in
       cont_a (next_index spec n) printer arg (succ i)
+    | 'r' as conv ->
+      bad_conversion_format fmt i conv
     | 't' ->
       let printer = get_arg spec n in
       cont_t (next_index spec n) printer (succ i)
@@ -570,8 +576,6 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
         let s = format_int (extract_format_int 'n' fmt pos i widths) x in
         cont_s (next_index spec n) s (succ i)
       end
-    | ',' -> cont_s n "" (succ i)
-    | '!' -> cont_f n (succ i)
     | '{' | '(' as conv (* ')' '}' *) ->
       let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in
       let i = succ i in
@@ -637,7 +641,7 @@ let mkprintf to_s get_out outc outs flush k fmt =
 let kfprintf k oc =
   mkprintf false (fun _ -> oc) output_char output_string flush k
 ;;
-let ifprintf oc = kapr (fun _ -> Obj.magic ignore);;
+let ifprintf _ = kapr (fun _ -> Obj.magic ignore);;
 
 let fprintf oc = kfprintf ignore oc;;
 let printf fmt = fprintf stdout fmt;;
@@ -670,7 +674,7 @@ let sprintf fmt = ksprintf (fun s -> s) fmt;;
 (* Obsolete and deprecated. *)
 let kprintf = ksprintf;;
 
-(* For Caml system internal use only: needed to implement modules [Format]
+(* For OCaml system internal use only: needed to implement modules [Format]
   and [Scanf]. *)
 
 module CamlinternalPr = struct

diff --git a/stdlib/printf.mli b/stdlib/printf.mli
index e122dececa8360b8e59743c6d7167b9476f3914a..6fcb45ebac2e4dd24a9a0bcfaf7f5f6ab0834d85 100644 (file)
--- a/stdlib/printf.mli
+++ b/stdlib/printf.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*  Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
@@ -20,71 +20,77 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
    [arg1] to [argN] according to the format string [format], and
    outputs the resulting string on the channel [outchan].
 
-   The format is a character string which contains two types of
+   The format string is a character string which contains two types of
    objects: plain characters, which are simply copied to the output
    channel, and conversion specifications, each of which causes
    conversion and printing of arguments.
 
    Conversion specifications have the following form:
 
-   [% \[flags\] \[width\] \[.precision\] type]
+   [% [flags] [width] [.precision] type]
 
    In short, a conversion specification consists in the [%] character,
    followed by optional modifiers and a type which is made of one or
-   two characters. The types and their meanings are:
+   two characters.
 
-   - [d], [i], [n], [l], [L], or [N]: convert an integer argument to
-     signed decimal.
-   - [u]: convert an integer argument to unsigned decimal.
+   The types and their meanings are:
+
+   - [d], [i]: convert an integer argument to signed decimal.
+   - [u], [n], [l], [L], or [N]: convert an integer argument to
+     unsigned decimal.  Warning: [n], [l], [L], and [N] are
+     used for [scanf], and should not be used for [printf].
    - [x]: convert an integer argument to unsigned hexadecimal,
      using lowercase letters.
    - [X]: convert an integer argument to unsigned hexadecimal,
      using uppercase letters.
    - [o]: convert an integer argument to unsigned octal.
    - [s]: insert a string argument.
-   - [S]: insert a string argument in Caml syntax (double quotes, escapes).
+   - [S]: convert a string argument to OCaml syntax (double quotes, escapes).
    - [c]: insert a character argument.
-   - [C]: insert a character argument in Caml syntax (single quotes, escapes).
+   - [C]: convert a character argument to OCaml syntax (single quotes, escapes).
    - [f]: convert a floating-point argument to decimal notation,
      in the style [dddd.ddd].
-   - [F]: convert a floating-point argument to Caml syntax ([dddd.]
+   - [F]: convert a floating-point argument to OCaml syntax ([dddd.]
      or [dddd.ddd] or [d.ddd e+-dd]).
    - [e] or [E]: convert a floating-point argument to decimal notation,
      in the style [d.ddd e+-dd] (mantissa and exponent).
    - [g] or [G]: convert a floating-point argument to decimal notation,
      in style [f] or [e], [E] (whichever is more compact).
    - [B]: convert a boolean argument to the string [true] or [false]
-   - [b]: convert a boolean argument (for backward compatibility; do not
-     use in new programs).
+   - [b]: convert a boolean argument (deprecated; do not use in new
+     programs).
    - [ld], [li], [lu], [lx], [lX], [lo]: convert an [int32] argument to
      the format specified by the second letter (decimal, hexadecimal, etc).
    - [nd], [ni], [nu], [nx], [nX], [no]: convert a [nativeint] argument to
      the format specified by the second letter.
    - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an [int64] argument to
      the format specified by the second letter.
-   - [a]: user-defined printer. Takes two arguments and applies the
+   - [a]: user-defined printer. Take two arguments and apply the
      first one to [outchan] (the current output channel) and to the
      second argument. The first argument must therefore have type
      [out_channel -> 'b -> unit] and the second ['b].
      The output produced by the function is inserted in the output of
      [fprintf] at the current point.
-   - [t]: same as [%a], but takes only one argument (with type
+   - [t]: same as [%a], but take only one argument (with type
      [out_channel -> unit]) and apply it to [outchan].
    - [\{ fmt %\}]: convert a format string argument. The argument must
      have the same type as the internal format string [fmt].
-   - [( fmt %)]: format string substitution. Takes a format string
-     argument and substitutes it to the internal format string [fmt]
+   - [( fmt %)]: format string substitution. Take a format string
+     argument and substitute it to the internal format string [fmt]
      to print following arguments. The argument must have the same
      type as the internal format string [fmt].
    - [!]: take no argument and flush the output.
    - [%]: take no argument and output one [%] character.
-   - [,]: the no-op delimiter for conversion specifications.
+   - [\@]: take no argument and output one [\@] character.
+   - [,]: take no argument and do nothing.
 
    The optional [flags] are:
    - [-]: left-justify the output (default is right justification).
    - [0]: for numerical conversions, pad with zeroes instead of spaces.
-   - [+]: for numerical conversions, prefix number with a [+] sign if positive.
-   - space: for numerical conversions, prefix number with a space if positive.
+   - [+]: for signed numerical conversions, prefix number with a [+]
+     sign if positive.
+   - space: for signed numerical conversions, prefix number with a
+     space if positive.
    - [#]: request an alternate formatting style for numbers.
 
    The optional [width] is an integer indicating the minimal
@@ -153,7 +159,7 @@ val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
 
 (**/**)
 
-(* For Caml system internal use only. Don't call directly. *)
+(* The following is for system use only. Do not call directly. *)
 
 module CamlinternalPr : sig
 

diff --git a/stdlib/queue.ml b/stdlib/queue.ml
index 9e21686a13b1912e1731c1e5813855a0fae9b4cc..388a46c539e1e0f2cf85c7099bc9aae90cbee40e 100644 (file)
--- a/stdlib/queue.ml
+++ b/stdlib/queue.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*        François Pottier, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -15,7 +15,7 @@
 
 exception Empty
 
-(* O'Caml currently does not allow the components of a sum type to be
+(* OCaml currently does not allow the components of a sum type to be
    mutable. Yet, for optimal space efficiency, we must have cons cells
    whose [next] field is mutable. This leads us to define a type of
    cyclic lists, so as to eliminate the [Nil] case and the sum
@@ -54,12 +54,12 @@ let clear q =
   q.tail <- Obj.magic None
 
 let add x q =
-  q.length <- q.length + 1;
-  if q.length = 1 then
+  if q.length = 0 then
     let rec cell = {
       content = x;
       next = cell
     } in
+    q.length <- 1;
     q.tail <- cell
   else
     let tail = q.tail in
@@ -68,6 +68,7 @@ let add x q =
       content = x;
       next = head
     } in
+    q.length <- q.length + 1;
     tail.next <- cell;
     q.tail <- cell
 

diff --git a/stdlib/queue.mli b/stdlib/queue.mli
index 085cfb003e1036616cdc049c8880ba6af570df98..5dea9244bcc1dfd99451eca0efdc764276f8a6a3 100644 (file)
--- a/stdlib/queue.mli
+++ b/stdlib/queue.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/random.ml b/stdlib/random.ml
index bd3979914a85972c4a77d796e6400e7a5ab1b05c..800c62970698b433284e2dad5b99356f18f4edd5 100644 (file)
--- a/stdlib/random.ml
+++ b/stdlib/random.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Damien Doligez, projet Para, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -25,7 +25,7 @@
    passes all the Diehard tests.
 *)
 
-external random_seed: unit -> int = "caml_sys_random_seed";;
+external random_seed: unit -> int array = "caml_sys_random_seed";;
 
 module State = struct
 
@@ -43,7 +43,7 @@ module State = struct
       Char.code d.[0] + (Char.code d.[1] lsl 8) + (Char.code d.[2] lsl 16)
       + (Char.code d.[3] lsl 24)
     in
-    let seed = if seed = [| |] then [| 0 |] else seed in
+    let seed = if Array.length seed = 0 then [| 0 |] else seed in
     let l = Array.length seed in
     for i = 0 to 54 do
       s.st.(i) <- i;
@@ -53,7 +53,7 @@ module State = struct
       let j = i mod 55 in
       let k = i mod l in
       accu := combine !accu seed.(k);
-      s.st.(j) <- s.st.(j) lxor extract !accu;
+      s.st.(j) <- (s.st.(j) lxor extract !accu) land 0x3FFFFFFF;  (* PR#5575 *)
     done;
     s.idx <- 0;
   ;;
@@ -64,7 +64,7 @@ module State = struct
     result
   ;;
 
-  let make_self_init () = make [| random_seed () |];;
+  let make_self_init () = make (random_seed ());;
 
   let copy s =
     let result = new_state () in
@@ -75,10 +75,12 @@ module State = struct
   (* Returns 30 random bits as an integer 0 <= x < 1073741824 *)
   let bits s =
     s.idx <- (s.idx + 1) mod 55;
+    let curval = s.st.(s.idx) in
     let newval = s.st.((s.idx + 24) mod 55)
-                 + (s.st.(s.idx) lxor ((s.st.(s.idx) lsr 25) land 31)) in
-    s.st.(s.idx) <- newval;
-    newval land 0x3FFFFFFF   (* land is needed for 64-bit arch *)
+                 + (curval lxor ((curval lsr 25) land 0x1F)) in
+    let newval30 = newval land 0x3FFFFFFF in  (* PR#5575 *)
+    s.st.(s.idx) <- newval30;
+    newval30
   ;;
 
   let rec intaux s n =
@@ -129,13 +131,12 @@ module State = struct
     else fun s bound -> Int64.to_nativeint (int64 s (Int64.of_nativeint bound))
   ;;
 
-  (* Returns a float 0 <= x < 1 with at most 90 bits of precision. *)
+  (* Returns a float 0 <= x <= 1 with at most 60 bits of precision. *)
   let rawfloat s =
-    let scale = 1073741824.0
-    and r0 = Pervasives.float (bits s)
+    let scale = 1073741824.0  (* 2^30 *)
     and r1 = Pervasives.float (bits s)
     and r2 = Pervasives.float (bits s)
-    in ((r0 /. scale +. r1) /. scale +. r2) /. scale
+    in (r1 /. scale +. r2) /. scale
   ;;
 
   let float s bound = rawfloat s *. bound;;
@@ -171,7 +172,7 @@ let bool () = State.bool default;;
 
 let full_init seed = State.full_init default seed;;
 let init seed = State.full_init default [| seed |];;
-let self_init () = init (random_seed());;
+let self_init () = full_init (random_seed());;
 
 (* Manipulating the current state. *)
 

diff --git a/stdlib/random.mli b/stdlib/random.mli
index 88387d191be130f9ad79fa3943dee3c1527b8b92..d8ea01e621445185466219c23225744dad37489c 100644 (file)
--- a/stdlib/random.mli
+++ b/stdlib/random.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Damien Doligez, projet Para, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -25,8 +25,11 @@ val full_init : int array -> unit
 (** Same as {!Random.init} but takes more data as seed. *)
 
 val self_init : unit -> unit
-(** Initialize the generator with a more-or-less random seed chosen
-   in a system-dependent way. *)
+(** Initialize the generator with a random seed chosen
+   in a system-dependent way.  If [/dev/urandom] is available on
+   the host machine, it is used to provide a highly random initial
+   seed.  Otherwise, a less random seed is computed from system
+   parameters (current time, process IDs). *)
 
 val bits : unit -> int
 (** Return 30 random bits in a nonnegative integer.
@@ -53,7 +56,7 @@ val int64 : Int64.t -> Int64.t;;
 
 val float : float -> float
 (** [Random.float bound] returns a random floating-point number
-   between 0 (inclusive) and [bound] (exclusive).  If [bound] is
+   between 0 and [bound] (inclusive).  If [bound] is
    negative, the result is negative or zero.  If [bound] is 0,
    the result is 0. *)
 
@@ -64,7 +67,7 @@ val bool : unit -> bool
 (** {6 Advanced functions} *)
 
 (** The functions from module [State] manipulate the current state
-    of the random generator explicitely.
+    of the random generator explicitly.
     This allows using one or several deterministic PRNGs,
     even in a multi-threaded program, without interference from
     other parts of the program.

diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml
index 3d3d16c233b9c439ff8585ad3bb46e21fca3ceff..cac4a136a4c299a4c842c3681b6e2179227f939c 100644 (file)
--- a/stdlib/scanf.ml
+++ b/stdlib/scanf.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -22,6 +22,8 @@ module type SCANNING = sig
 
   type scanbuf = in_channel;;
 
+  type file_name = string;;
+
   val stdin : in_channel;;
   (* The scanning buffer reading from [Pervasives.stdin].
       [stdib] is equivalent to [Scanning.from_channel Pervasives.stdin]. *)
@@ -104,15 +106,15 @@ module type SCANNING = sig
   (* [Scanning.name_of_input ib] returns the name of the character
       source for input buffer [ib]. *)
 
-  val open_in : string -> scanbuf;;
-  val open_in_bin : string -> scanbuf;;
-  val from_file : string -> scanbuf;;
-  val from_file_bin : string -> scanbuf;;
-  val from_string : string -> scanbuf;;
-  val from_function : (unit -> char) -> scanbuf;;
-  val from_channel : Pervasives.in_channel -> scanbuf;;
+  val open_in : file_name -> in_channel;;
+  val open_in_bin : file_name -> in_channel;;
+  val from_file : file_name -> in_channel;;
+  val from_file_bin : file_name -> in_channel;;
+  val from_string : string -> in_channel;;
+  val from_function : (unit -> char) -> in_channel;;
+  val from_channel : Pervasives.in_channel -> in_channel;;
 
-  val close_in : scanbuf -> unit;;
+  val close_in : in_channel -> unit;;
 
 end
 ;;
@@ -142,6 +144,8 @@ module Scanning : SCANNING = struct
 
   type scanbuf = in_channel;;
 
+  type file_name = string;;
+
   let null_char = '\000';;
 
   (* Reads a new character from input buffer.  Next_char never fails,
@@ -210,16 +214,16 @@ module Scanning : SCANNING = struct
 
   let token_count ib = ib.token_count;;
 
-  let skip_char max ib =
+  let skip_char width ib =
     invalidate_current_char ib;
-    max
+    width
   ;;
 
-  let ignore_char max ib = skip_char (max - 1) ib;;
+  let ignore_char width ib = skip_char (width - 1) ib;;
 
-  let store_char max ib c =
+  let store_char width ib c =
     Buffer.add_char ib.tokbuf c;
-    ignore_char max ib
+    ignore_char width ib
   ;;
 
   let default_token_buffer_size = 1024;;
@@ -428,19 +432,14 @@ let bad_end_of_input message =
         premature end of file occurred before end of token" message)
 ;;
 
-let int_max = function
+let int_of_width_opt = function
   | None -> max_int
-  | Some max -> max
-;;
-
-let int_min = function
-  | None -> 0
-  | Some max -> max
+  | Some width -> width
 ;;
 
-let float_min = function
+let int_of_prec_opt = function
   | None -> max_int
-  | Some min -> min
+  | Some prec -> prec
 ;;
 
 module Sformat = Printf.CamlinternalPr.Sformat;;
@@ -484,7 +483,7 @@ let compatible_format_type fmt1 fmt2 =
   Tformat.summarize_format_type (string_to_format fmt2);;
 
 (* Checking that [c] is indeed in the input, then skips it.
-   In this case, the character c has been explicitely specified in the
+   In this case, the character c has been explicitly specified in the
    format as being mandatory in the input; hence we should fail with
    End_of_file in case of end_of_input. (Remember that Scan_failure is raised
    only when (we can prove by evidence) that the input does not match the
@@ -589,55 +588,55 @@ let token_int64 conv ib = int64_of_string (token_int_literal conv ib);;
    available before calling one of the digit scanning functions). *)
 
 (* The decimal case is treated especially for optimization purposes. *)
-let rec scan_decimal_digits max ib =
-  if max = 0 then max else
+let rec scan_decimal_digits width ib =
+  if width = 0 then width else
   let c = Scanning.peek_char ib in
-  if Scanning.eof ib then max else
+  if Scanning.eof ib then width else
   match c with
   | '0' .. '9' as c ->
-    let max = Scanning.store_char max ib c in
-    scan_decimal_digits max ib
+    let width = Scanning.store_char width ib c in
+    scan_decimal_digits width ib
   | '_' ->
-    let max = Scanning.ignore_char max ib in
-    scan_decimal_digits max ib
-  | _ -> max
+    let width = Scanning.ignore_char width ib in
+    scan_decimal_digits width ib
+  | _ -> width
 ;;
 
-let scan_decimal_digits_plus max ib =
-  if max = 0 then bad_token_length "decimal digits" else
+let scan_decimal_digits_plus width ib =
+  if width = 0 then bad_token_length "decimal digits" else
   let c = Scanning.checked_peek_char ib in
   match c with
   | '0' .. '9' ->
-    let max = Scanning.store_char max ib c in
-    scan_decimal_digits max ib
+    let width = Scanning.store_char width ib c in
+    scan_decimal_digits width ib
   | c ->
     bad_input (Printf.sprintf "character %C is not a decimal digit" c)
 ;;
 
-let scan_digits_plus digitp max ib =
+let scan_digits_plus digitp width ib =
   (* To scan numbers from other bases, we use a predicate argument to
      scan_digits. *)
-  let rec scan_digits max =
-    if max = 0 then max else
+  let rec scan_digits width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     match c with
     | c when digitp c ->
-      let max = Scanning.store_char max ib c in
-      scan_digits max
+      let width = Scanning.store_char width ib c in
+      scan_digits width
     | '_' ->
-      let max = Scanning.ignore_char max ib in
-      scan_digits max
-    | _ -> max in
+      let width = Scanning.ignore_char width ib in
+      scan_digits width
+    | _ -> width in
 
   (* Ensure we have got enough width left,
      and read at list one digit. *)
-  if max = 0 then bad_token_length "digits" else
+  if width = 0 then bad_token_length "digits" else
   let c = Scanning.checked_peek_char ib in
 
   if digitp c then
-    let max = Scanning.store_char max ib c in
-    scan_digits max
+    let width = Scanning.store_char width ib c in
+    scan_digits width
   else
     bad_input (Printf.sprintf "character %C is not a digit" c)
 ;;
@@ -666,145 +665,147 @@ let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;;
 (* Scan a decimal integer. *)
 let scan_unsigned_decimal_int = scan_decimal_digits_plus;;
 
-let scan_sign max ib =
+let scan_sign width ib =
   let c = Scanning.checked_peek_char ib in
   match c with
-  | '+' -> Scanning.store_char max ib c
-  | '-' -> Scanning.store_char max ib c
-  | c -> max
+  | '+' -> Scanning.store_char width ib c
+  | '-' -> Scanning.store_char width ib c
+  | _ -> width
 ;;
 
-let scan_optionally_signed_decimal_int max ib =
-  let max = scan_sign max ib in
-  scan_unsigned_decimal_int max ib
+let scan_optionally_signed_decimal_int width ib =
+  let width = scan_sign width ib in
+  scan_unsigned_decimal_int width ib
 ;;
 
 (* Scan an unsigned integer that could be given in any (common) basis.
    If digits are prefixed by one of 0x, 0X, 0o, or 0b, the number is
    assumed to be written respectively in hexadecimal, hexadecimal,
    octal, or binary. *)
-let scan_unsigned_int max ib =
+let scan_unsigned_int width ib =
   match Scanning.checked_peek_char ib with
   | '0' as c ->
-    let max = Scanning.store_char max ib c in
-    if max = 0 then max else
+    let width = Scanning.store_char width ib c in
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     begin match c with
-    | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char max ib c) ib
-    | 'o' -> scan_octal_int (Scanning.store_char max ib c) ib
-    | 'b' -> scan_binary_int (Scanning.store_char max ib c) ib
-    | c -> scan_decimal_digits max ib end
-  | c -> scan_unsigned_decimal_int max ib
+    | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char width ib c) ib
+    | 'o' -> scan_octal_int (Scanning.store_char width ib c) ib
+    | 'b' -> scan_binary_int (Scanning.store_char width ib c) ib
+    | _ -> scan_decimal_digits width ib end
+  | _ -> scan_unsigned_decimal_int width ib
 ;;
 
-let scan_optionally_signed_int max ib =
-  let max = scan_sign max ib in
-  scan_unsigned_int max ib
+let scan_optionally_signed_int width ib =
+  let width = scan_sign width ib in
+  scan_unsigned_int width ib
 ;;
 
-let scan_int_conv conv max _min ib =
+let scan_int_conv conv width _prec ib =
   match conv with
-  | 'b' -> scan_binary_int max ib
-  | 'd' -> scan_optionally_signed_decimal_int max ib
-  | 'i' -> scan_optionally_signed_int max ib
-  | 'o' -> scan_octal_int max ib
-  | 'u' -> scan_unsigned_decimal_int max ib
-  | 'x' | 'X' -> scan_hexadecimal_int max ib
-  | c -> assert false
+  | 'b' -> scan_binary_int width ib
+  | 'd' -> scan_optionally_signed_decimal_int width ib
+  | 'i' -> scan_optionally_signed_int width ib
+  | 'o' -> scan_octal_int width ib
+  | 'u' -> scan_unsigned_decimal_int width ib
+  | 'x' | 'X' -> scan_hexadecimal_int width ib
+  | _ -> assert false
 ;;
 
 (* Scanning floating point numbers. *)
 (* Fractional part is optional and can be reduced to 0 digits. *)
-let scan_frac_part max ib =
-  if max = 0 then max else
+let scan_frac_part width ib =
+  if width = 0 then width else
   let c = Scanning.peek_char ib in
-  if Scanning.eof ib then max else
+  if Scanning.eof ib then width else
   match c with
   | '0' .. '9' as c ->
-    scan_decimal_digits (Scanning.store_char max ib c) ib
-  | _ -> max
+    scan_decimal_digits (Scanning.store_char width ib c) ib
+  | _ -> width
 ;;
 
 (* Exp part is optional and can be reduced to 0 digits. *)
-let scan_exp_part max ib =
-  if max = 0 then max else
+let scan_exp_part width ib =
+  if width = 0 then width else
   let c = Scanning.peek_char ib in
-  if Scanning.eof ib then max else
+  if Scanning.eof ib then width else
   match c with
   | 'e' | 'E' as c ->
-    scan_optionally_signed_decimal_int (Scanning.store_char max ib c) ib
-  | _ -> max
+    scan_optionally_signed_decimal_int (Scanning.store_char width ib c) ib
+  | _ -> width
 ;;
 
 (* Scan the integer part of a floating point number, (not using the
-   Caml lexical convention since the integer part can be empty):
+   OCaml lexical convention since the integer part can be empty):
    an optional sign, followed by a possibly empty sequence of decimal
    digits (e.g. -.1). *)
-let scan_int_part max ib =
-  let max = scan_sign max ib in
-  scan_decimal_digits max ib
+let scan_int_part width ib =
+  let width = scan_sign width ib in
+  scan_decimal_digits width ib
 ;;
 
 (*
-    For the time being we have (as found in scanf.mli):
-    The field width is composed of an optional integer literal
-    indicating the maximal width of the token to read.
-    Unfortunately, the type-checker let the user write an optional precision,
-    since this is valid for printf format strings.
+   For the time being we have (as found in scanf.mli):
+   The field width is composed of an optional integer literal
+   indicating the maximal width of the token to read.
+   Unfortunately, the type-checker let the user write an optional precision,
+   since this is valid for printf format strings.
 
-   Thus, the next step for Scanf is to support a full width indication, more
-   or less similar to the one for printf, possibly extended to the
-   specification of a [max, min] range for the width of the token read for
-   strings. Something like the following spec for scanf.mli:
+   Thus, the next step for Scanf is to support a full width and precision
+   indication, more or less similar to the one for printf, possibly extended
+   to the specification of a [max, min] range for the width of the token read
+   for strings. Something like the following spec for scanf.mli:
 
    The optional [width] is an integer indicating the maximal
    width of the token read. For instance, [%6d] reads an integer,
    having at most 6 characters.
 
    The optional [precision] is a dot [.] followed by an integer:
-   - in the floating point number conversions ([%f], [%e], [%g], [%F], [%E], and
-   [%F] conversions, the [precision] indicates the maximum number of digits
-   that may follow the decimal point. For instance, [%.4f] reads a [float]
-   with at most 4 fractional digits,
+
+   - in the floating point number conversions ([%f], [%e], [%g], [%F], [%E],
+   and [%F] conversions, the [precision] indicates the maximum number of
+   digits that may follow the decimal point. For instance, [%.4f] reads a
+   [float] with at most 4 fractional digits,
+
    - in the string conversions ([%s], [%S], [%\[ range \]]), and in the
    integer number conversions ([%i], [%d], [%u], [%x], [%o], and their
-   [int32], [int64], and [native_int] correspondent), the
-   [precision] indicates the required minimum width of the token read,
+   [int32], [int64], and [native_int] correspondent), the [precision]
+   indicates the required minimum width of the token read,
+
    - on all other conversions, the width and precision are meaningless and
    ignored (FIXME: lead to a runtime error ? type checking error ?).
-
 *)
-let scan_float max max_frac_part ib =
-  let max = scan_int_part max ib in
-  if max = 0 then max, max_frac_part else
+
+let scan_float width precision ib =
+  let width = scan_int_part width ib in
+  if width = 0 then width, precision else
   let c = Scanning.peek_char ib in
-  if Scanning.eof ib then max, max_frac_part else
+  if Scanning.eof ib then width, precision else
   match c with
   | '.' ->
-    let max = Scanning.store_char max ib c in
-    let max_precision = min max max_frac_part in
-    let max = max - (max_precision - scan_frac_part max_precision ib) in
-    scan_exp_part max ib, max_frac_part
-  | c ->
-    scan_exp_part max ib, max_frac_part
+    let width = Scanning.store_char width ib c in
+    let precision = min width precision in
+    let width = width - (precision - scan_frac_part precision ib) in
+    scan_exp_part width ib, precision
+  | _ ->
+    scan_exp_part width ib, precision
 ;;
 
-let scan_Float max max_frac_part ib =
-  let max = scan_optionally_signed_decimal_int max ib in
-  if max = 0 then bad_float () else
+let scan_Float width precision ib =
+  let width = scan_optionally_signed_decimal_int width ib in
+  if width = 0 then bad_float () else
   let c = Scanning.peek_char ib in
   if Scanning.eof ib then bad_float () else
   match c with
   | '.' ->
-    let max = Scanning.store_char max ib c in
-    let max_precision = min max max_frac_part in
-    let max = max - (max_precision - scan_frac_part max_precision ib) in
-    let max = scan_frac_part max ib in
-    scan_exp_part max ib
+    let width = Scanning.store_char width ib c in
+    let precision = min width precision in
+    let width = width - (precision - scan_frac_part precision ib) in
+    scan_exp_part width ib
   | 'e' | 'E' ->
-    scan_exp_part max ib
-  | c -> bad_float ()
+    scan_exp_part width ib
+  | _ -> bad_float ()
 ;;
 
 (* Scan a regular string:
@@ -813,26 +814,26 @@ let scan_Float max max_frac_part ib =
    indication list [stp].
    It also stops at end of file or when the maximum number of characters has
    been read.*)
-let scan_string stp max ib =
-  let rec loop max =
-    if max = 0 then max else
+let scan_string stp width ib =
+  let rec loop width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if stp = [] then
       match c with
-      | ' ' | '\t' | '\n' | '\r' -> max
-      | c -> loop (Scanning.store_char max ib c) else
-    if List.memq c stp then Scanning.skip_char max ib else
-    loop (Scanning.store_char max ib c) in
-  loop max
+      | ' ' | '\t' | '\n' | '\r' -> width
+      | c -> loop (Scanning.store_char width ib c) else
+    if List.memq c stp then Scanning.skip_char width ib else
+    loop (Scanning.store_char width ib c) in
+  loop width
 ;;
 
 (* Scan a char: peek strictly one character in the input, whatsoever. *)
-let scan_char max ib =
-  (* The case max = 0 could not happen here, since it is tested before
+let scan_char width ib =
+  (* The case width = 0 could not happen here, since it is tested before
      calling scan_char, in the main scanning function.
-    if max = 0 then bad_token_length "a character" else *)
-  Scanning.store_char max ib (Scanning.checked_peek_char ib)
+    if width = 0 then bad_token_length "a character" else *)
+  Scanning.store_char width ib (Scanning.checked_peek_char ib)
 ;;
 
 let char_for_backslash = function
@@ -887,8 +888,8 @@ let char_for_hexadecimal_code c1 c2 =
 
 (* Called in particular when encountering '\\' as starter of a char.
    Stops before the corresponding '\''. *)
-let check_next_char message max ib =
-  if max = 0 then bad_token_length message else
+let check_next_char message width ib =
+  if width = 0 then bad_token_length message else
   let c = Scanning.peek_char ib in
   if Scanning.eof ib then bad_end_of_input message else
   c
@@ -897,10 +898,10 @@ let check_next_char message max ib =
 let check_next_char_for_char = check_next_char "a Char";;
 let check_next_char_for_string = check_next_char "a String";;
 
-let scan_backslash_char max ib =
-  match check_next_char_for_char max ib with
+let scan_backslash_char width ib =
+  match check_next_char_for_char width ib with
   | '\\' | '\'' | '\"' | 'n' | 't' | 'b' | 'r' as c ->
-    Scanning.store_char max ib (char_for_backslash c)
+    Scanning.store_char width ib (char_for_backslash c)
   | '0' .. '9' as c ->
     let get_digit () =
       let c = Scanning.next_char ib in
@@ -910,7 +911,7 @@ let scan_backslash_char max ib =
     let c0 = c in
     let c1 = get_digit () in
     let c2 = get_digit () in
-    Scanning.store_char (max - 2) ib (char_for_decimal_code c0 c1 c2)
+    Scanning.store_char (width - 2) ib (char_for_decimal_code c0 c1 c2)
   | 'x' ->
     let get_digit () =
       let c = Scanning.next_char ib in
@@ -919,68 +920,68 @@ let scan_backslash_char max ib =
       | c -> bad_input_escape c in
     let c1 = get_digit () in
     let c2 = get_digit () in
-    Scanning.store_char (max - 2) ib (char_for_hexadecimal_code c1 c2)
+    Scanning.store_char (width - 2) ib (char_for_hexadecimal_code c1 c2)
   | c ->
     bad_input_escape c
 ;;
 
-(* Scan a character (a Caml token). *)
-let scan_Char max ib =
+(* Scan a character (an OCaml token). *)
+let scan_Char width ib =
 
-  let rec find_start max =
+  let rec find_start width =
     match Scanning.checked_peek_char ib with
-    | '\'' -> find_char (Scanning.ignore_char max ib)
+    | '\'' -> find_char (Scanning.ignore_char width ib)
     | c -> character_mismatch '\'' c
 
-  and find_char max =
-    match check_next_char_for_char max ib with
-    | '\\' -> find_stop (scan_backslash_char (Scanning.ignore_char max ib) ib)
-    | c -> find_stop (Scanning.store_char max ib c)
+  and find_char width =
+    match check_next_char_for_char width ib with
+    | '\\' -> find_stop (scan_backslash_char (Scanning.ignore_char width ib) ib)
+    | c -> find_stop (Scanning.store_char width ib c)
 
-  and find_stop max =
-    match check_next_char_for_char max ib with
-    | '\'' -> Scanning.ignore_char max ib
+  and find_stop width =
+    match check_next_char_for_char width ib with
+    | '\'' -> Scanning.ignore_char width ib
     | c -> character_mismatch '\'' c in
 
-  find_start max
+  find_start width
 ;;
 
-(* Scan a delimited string (a Caml token). *)
-let scan_String max ib =
+(* Scan a delimited string (an OCaml token). *)
+let scan_String width ib =
 
-  let rec find_start max =
+  let rec find_start width =
     match Scanning.checked_peek_char ib with
-    | '\"' -> find_stop (Scanning.ignore_char max ib)
+    | '\"' -> find_stop (Scanning.ignore_char width ib)
     | c -> character_mismatch '\"' c
 
-  and find_stop max =
-    match check_next_char_for_string max ib with
-    | '\"' -> Scanning.ignore_char max ib
-    | '\\' -> scan_backslash (Scanning.ignore_char max ib)
-    | c -> find_stop (Scanning.store_char max ib c)
+  and find_stop width =
+    match check_next_char_for_string width ib with
+    | '\"' -> Scanning.ignore_char width ib
+    | '\\' -> scan_backslash (Scanning.ignore_char width ib)
+    | c -> find_stop (Scanning.store_char width ib c)
 
-  and scan_backslash max =
-    match check_next_char_for_string max ib with
-    | '\r' -> skip_newline (Scanning.ignore_char max ib)
-    | '\n' -> skip_spaces (Scanning.ignore_char max ib)
-    | c -> find_stop (scan_backslash_char max ib)
+  and scan_backslash width =
+    match check_next_char_for_string width ib with
+    | '\r' -> skip_newline (Scanning.ignore_char width ib)
+    | '\n' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop (scan_backslash_char width ib)
 
-  and skip_newline max =
-    match check_next_char_for_string max ib with
-    | '\n' -> skip_spaces (Scanning.ignore_char max ib)
-    | _ -> find_stop (Scanning.store_char max ib '\r')
+  and skip_newline width =
+    match check_next_char_for_string width ib with
+    | '\n' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop (Scanning.store_char width ib '\r')
 
-  and skip_spaces max =
-    match check_next_char_for_string max ib with
-    | ' ' -> skip_spaces (Scanning.ignore_char max ib)
-    | _ -> find_stop max in
+  and skip_spaces width =
+    match check_next_char_for_string width ib with
+    | ' ' -> skip_spaces (Scanning.ignore_char width ib)
+    | _ -> find_stop width in
 
-  find_start max
+  find_start width
 ;;
 
-(* Scan a boolean (a Caml token). *)
-let scan_bool max ib =
-  if max < 4 then bad_token_length "a boolean" else
+(* Scan a boolean (an OCaml token). *)
+let scan_bool width ib =
+  if width < 4 then bad_token_length "a boolean" else
   let c = Scanning.checked_peek_char ib in
   let m =
     match c with
@@ -989,7 +990,7 @@ let scan_bool max ib =
     | c ->
       bad_input
         (Printf.sprintf "the character %C cannot start a boolean" c) in
-  scan_string [] (min max m) ib
+  scan_string [] (min width m) ib
 ;;
 
 (* Reading char sets in %[...] conversions. *)
@@ -998,31 +999,51 @@ type char_set =
    | Neg_set of string (* Negative (complementary) set. *)
 ;;
 
+
 (* Char sets are read as sub-strings in the format string. *)
-let read_char_set fmt i =
-  let lim = Sformat.length fmt - 1 in
+let scan_range fmt j =
+
+  let len = Sformat.length fmt in
 
-  let rec find_in_set j =
-    if j > lim then incomplete_format fmt else
+  let buffer = Buffer.create len in
+
+  let rec scan_closing j =
+    if j >= len then incomplete_format fmt else
     match Sformat.get fmt j with
-    | ']' -> j
-    | c -> find_in_set (succ j)
-
-  and find_set i =
-    if i > lim then incomplete_format fmt else
-    match Sformat.get fmt i with
-    | ']' -> find_in_set (succ i)
-    | c -> find_in_set i in
-
-  if i > lim then incomplete_format fmt else
-  match Sformat.get fmt i with
-  | '^' ->
-    let i = succ i in
-    let j = find_set i in
-    j, Neg_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
-  | _ ->
-    let j = find_set i in
-    j, Pos_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
+    | ']' -> j, Buffer.contents buffer
+    | '%' ->
+      let j = j + 1 in
+      if j >= len then incomplete_format fmt else
+      begin match Sformat.get fmt j with
+      | '%' | '@' as c ->
+        Buffer.add_char buffer c;
+        scan_closing (j + 1)
+      | c -> bad_conversion fmt j c
+      end
+    | c ->
+      Buffer.add_char buffer c;
+      scan_closing (j + 1) in
+
+  let scan_first_pos j =
+    if j >= len then incomplete_format fmt else
+    match Sformat.get fmt j with
+    | ']' as c ->
+      Buffer.add_char buffer c;
+      scan_closing (j + 1)
+    | _ -> scan_closing j in
+
+  let rec scan_first_neg j =
+    if j >= len then incomplete_format fmt else
+    match Sformat.get fmt j with
+    | '^' ->
+      let j = j + 1 in
+      let k, char_set = scan_first_pos j in
+      k, Neg_set char_set
+    | _ ->
+      let k, char_set = scan_first_pos j in
+      k, Pos_set char_set in
+
+  scan_first_neg j
 ;;
 
 (* Char sets are now represented as bit vectors that are represented as
@@ -1082,7 +1103,7 @@ let make_char_bit_vect bit set =
       for j = int_of_char c1 to int_of_char c2 do
         set_bit_of_range r j bit done;
       loop bit false (succ i)
-    | c ->
+    | _ ->
       set_bit_of_range r (int_of_char set.[i]) bit;
       loop bit true (succ i) in
   loop bit false 0;
@@ -1090,7 +1111,7 @@ let make_char_bit_vect bit set =
 ;;
 
 (* Compute the predicate on chars corresponding to a char set. *)
-let make_pred bit set stp =
+let make_predicate bit set stp =
   let r = make_char_bit_vect bit set in
   List.iter
     (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp;
@@ -1101,7 +1122,7 @@ let make_setp stp char_set =
   match char_set with
   | Pos_set set ->
     begin match String.length set with
-    | 0 -> (fun c -> 0)
+    | 0 -> (fun _ -> 0)
     | 1 ->
       let p = set.[0] in
       (fun c -> if c == p then 1 else 0)
@@ -1110,13 +1131,13 @@ let make_setp stp char_set =
       (fun c -> if c == p1 || c == p2 then 1 else 0)
     | 3 ->
       let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
-      if p2 = '-' then make_pred 1 set stp else
+      if p2 = '-' then make_predicate 1 set stp else
       (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0)
-    | n -> make_pred 1 set stp
+    | _ -> make_predicate 1 set stp
     end
   | Neg_set set ->
     begin match String.length set with
-    | 0 -> (fun c -> 1)
+    | 0 -> (fun _ -> 1)
     | 1 ->
       let p = set.[0] in
       (fun c -> if c != p then 1 else 0)
@@ -1125,9 +1146,9 @@ let make_setp stp char_set =
       (fun c -> if c != p1 && c != p2 then 1 else 0)
     | 3 ->
       let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in
-      if p2 = '-' then make_pred 0 set stp else
+      if p2 = '-' then make_predicate 0 set stp else
       (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0)
-    | n -> make_pred 0 set stp
+    | _ -> make_predicate 0 set stp
     end
 ;;
 
@@ -1151,75 +1172,75 @@ let find_setp stp char_set =
     setp
 ;;
 
-let scan_chars_in_char_set stp char_set max ib =
-  let rec loop_pos1 cp1 max =
-    if max = 0 then max else
+let scan_chars_in_char_set stp char_set width ib =
+  let rec loop_pos1 cp1 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c == cp1
-    then loop_pos1 cp1 (Scanning.store_char max ib c)
-    else max
-  and loop_pos2 cp1 cp2 max =
-    if max = 0 then max else
+    then loop_pos1 cp1 (Scanning.store_char width ib c)
+    else width
+  and loop_pos2 cp1 cp2 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c == cp1 || c == cp2
-    then loop_pos2 cp1 cp2 (Scanning.store_char max ib c)
-    else max
-  and loop_pos3 cp1 cp2 cp3 max =
-    if max = 0 then max else
+    then loop_pos2 cp1 cp2 (Scanning.store_char width ib c)
+    else width
+  and loop_pos3 cp1 cp2 cp3 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c == cp1 || c == cp2 || c == cp3
-    then loop_pos3 cp1 cp2 cp3 (Scanning.store_char max ib c)
-    else max
-  and loop_neg1 cp1 max =
-    if max = 0 then max else
+    then loop_pos3 cp1 cp2 cp3 (Scanning.store_char width ib c)
+    else width
+  and loop_neg1 cp1 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c != cp1
-    then loop_neg1 cp1 (Scanning.store_char max ib c)
-    else max
-  and loop_neg2 cp1 cp2 max =
-    if max = 0 then max else
+    then loop_neg1 cp1 (Scanning.store_char width ib c)
+    else width
+  and loop_neg2 cp1 cp2 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c != cp1 && c != cp2
-    then loop_neg2 cp1 cp2 (Scanning.store_char max ib c)
-    else max
-  and loop_neg3 cp1 cp2 cp3 max =
-    if max = 0 then max else
+    then loop_neg2 cp1 cp2 (Scanning.store_char width ib c)
+    else width
+  and loop_neg3 cp1 cp2 cp3 width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if c != cp1 && c != cp2 && c != cp3
-    then loop_neg3 cp1 cp2 cp3 (Scanning.store_char max ib c)
-    else max
-  and loop setp max =
-    if max = 0 then max else
+    then loop_neg3 cp1 cp2 cp3 (Scanning.store_char width ib c)
+    else width
+  and loop setp width =
+    if width = 0 then width else
     let c = Scanning.peek_char ib in
-    if Scanning.eof ib then max else
+    if Scanning.eof ib then width else
     if setp c == 1
-    then loop setp (Scanning.store_char max ib c)
-    else max in
+    then loop setp (Scanning.store_char width ib c)
+    else width in
 
-  let max =
+  let width =
     match char_set with
     | Pos_set set ->
       begin match String.length set with
-      | 0 -> loop (fun c -> 0) max
-      | 1 -> loop_pos1 set.[0] max
-      | 2 -> loop_pos2 set.[0] set.[1] max
-      | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] max
-      | n -> loop (find_setp stp char_set) max end
+      | 0 -> loop (fun _ -> 0) width
+      | 1 -> loop_pos1 set.[0] width
+      | 2 -> loop_pos2 set.[0] set.[1] width
+      | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] width
+      | _ -> loop (find_setp stp char_set) width end
     | Neg_set set ->
       begin match String.length set with
-      | 0 -> loop (fun c -> 1) max
-      | 1 -> loop_neg1 set.[0] max
-      | 2 -> loop_neg2 set.[0] set.[1] max
-      | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max
-      | n -> loop (find_setp stp char_set) max end in
+      | 0 -> loop (fun _ -> 1) width
+      | 1 -> loop_neg1 set.[0] width
+      | 2 -> loop_neg2 set.[0] set.[1] width
+      | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] width
+      | _ -> loop (find_setp stp char_set) width end in
   ignore_stoppers stp ib;
-  max
+  width
 ;;
 
 let get_count t ib =
@@ -1305,7 +1326,7 @@ let scan_format ib ef fmt rv f =
   let return v = Obj.magic v () in
   let delay f x () = f x in
   let stack f = delay (return f) in
-  let no_stack f x = f in
+  let no_stack f _x = f in
 
   let rec scan fmt =
 
@@ -1313,14 +1334,9 @@ let scan_format ib ef fmt rv f =
 
     let rec scan_fmt ir f i =
       if i > lim then ir, f else
-      match Sformat.get fmt i with
-      | ' ' -> skip_whites ib; scan_fmt ir f (succ i)
+      match Sformat.unsafe_get fmt i with
       | '%' -> scan_skip ir f (succ i)
-      | '@' ->
-        let i = succ i in
-        if i > lim then incomplete_format fmt else begin
-        check_char ib (Sformat.get fmt i);
-        scan_fmt ir f (succ i) end
+      | ' ' -> skip_whites ib; scan_fmt ir f (succ i)
       | c -> check_char ib c; scan_fmt ir f (succ i)
 
     and scan_skip ir f i =
@@ -1330,78 +1346,88 @@ let scan_format ib ef fmt rv f =
       | _ -> scan_limits false ir f i
 
     and scan_limits skip ir f i =
-      if i > lim then ir, f else
-      let max_opt, min_opt, i =
+
+      let rec scan_width i =
+        if i > lim then incomplete_format fmt else
         match Sformat.get fmt i with
         | '0' .. '9' as conv ->
-          let rec read_width accu i =
-            if i > lim then accu, i else
-            match Sformat.get fmt i with
-            | '0' .. '9' as c ->
-              let accu = 10 * accu + decimal_value_of_char c in
-              read_width accu (succ i)
-            | _ -> accu, i in
-
-          let max, i = read_width (decimal_value_of_char conv) (succ i) in
-
-          if i > lim then incomplete_format fmt else
-          begin
-            match Sformat.get fmt i with
-            | '.' ->
-              let min, i = read_width 0 (succ i) in
-              (Some max, Some min, i)
-            | _ -> Some max, None, i
-          end
-        | _ -> None, None, i in
+          let width, i = read_int_literal (decimal_value_of_char conv) (succ i) in
+          Some width, i
+        | _ -> None, i
+
+      and scan_precision i =
+        begin
+          match Sformat.get fmt i with
+          | '.' ->
+            let precision, i = read_int_literal 0 (succ i) in
+            (Some precision, i)
+          | _ -> None, i
+        end
 
-      scan_conversion skip max_opt min_opt ir f i
+      and read_int_literal accu i =
+        if i > lim then accu, i else
+        match Sformat.unsafe_get fmt i with
+        | '0' .. '9' as c ->
+          let accu = 10 * accu + decimal_value_of_char c in
+          read_int_literal accu (succ i)
+        | _ -> accu, i in
 
-    and scan_conversion skip max_opt min_opt ir f i =
+      if i > lim then ir, f else
+      let width_opt, i = scan_width i in
+      let prec_opt, i = scan_precision i in
+      scan_conversion skip width_opt prec_opt ir f i
+
+    and scan_conversion skip width_opt prec_opt ir f i =
       let stack = if skip then no_stack else stack in
-      let max = int_max max_opt in
-      let min = int_min min_opt in
+      let width = int_of_width_opt width_opt in
+      let prec = int_of_prec_opt prec_opt in
       match Sformat.get fmt i with
-      | '%' as conv ->
-        check_char ib conv; scan_fmt ir f (succ i)
+      | '%' | '@' as c ->
+        check_char ib c;
+        scan_fmt ir f (succ i)
+      | '!' ->
+        if not (Scanning.end_of_input ib)
+        then bad_input "end of input not found" else
+        scan_fmt ir f (succ i)
+      | ',' ->
+        scan_fmt ir f (succ i)
       | 's' ->
-        let i, stp = scan_fmt_stoppers (succ i) in
-        let _x = scan_string stp max ib in
+        let i, stp = scan_indication (succ i) in
+        let _x = scan_string stp width ib in
         scan_fmt ir (stack f (token_string ib)) (succ i)
       | 'S' ->
-        let _x = scan_String max ib in
+        let _x = scan_String width ib in
         scan_fmt ir (stack f (token_string ib)) (succ i)
       | '[' (* ']' *) ->
-        let i, char_set = read_char_set fmt (succ i) in
-        let i, stp = scan_fmt_stoppers (succ i) in
-        let _x = scan_chars_in_char_set stp char_set max ib in
+        let i, char_set = scan_range fmt (succ i) in
+        let i, stp = scan_indication (succ i) in
+        let _x = scan_chars_in_char_set stp char_set width ib in
         scan_fmt ir (stack f (token_string ib)) (succ i)
-      | ('c' | 'C') when max = 0 ->
+      | ('c' | 'C') when width = 0 ->
         let c = Scanning.checked_peek_char ib in
         scan_fmt ir (stack f c) (succ i)
       | 'c' ->
-        let _x = scan_char max ib in
+        let _x = scan_char width ib in
         scan_fmt ir (stack f (token_char ib)) (succ i)
       | 'C' ->
-        let _x = scan_Char max ib in
+        let _x = scan_Char width ib in
         scan_fmt ir (stack f (token_char ib)) (succ i)
       | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv ->
-        let _x = scan_int_conv conv max min ib in
+        let _x = scan_int_conv conv width prec ib in
         scan_fmt ir (stack f (token_int conv ib)) (succ i)
       | 'N' as conv ->
         scan_fmt ir (stack f (get_count conv ib)) (succ i)
       | 'f' | 'e' | 'E' | 'g' | 'G' ->
-        let min = float_min min_opt in
-        let _x = scan_float max min ib in
+        let _x = scan_float width prec ib in
         scan_fmt ir (stack f (token_float ib)) (succ i)
       | 'F' ->
-        let min = float_min min_opt in
-        let _x = scan_Float max min ib in
+        let _x = scan_Float width prec ib in
         scan_fmt ir (stack f (token_float ib)) (succ i)
-(*      | 'B' | 'b' when max = Some 0 ->
-        let _x = scan_bool max ib in
+(*      | 'B' | 'b' when width = Some 0 ->
+        let _x = scan_bool width ib in
         scan_fmt ir (stack f (token_int ib)) (succ i) *)
       | 'B' | 'b' ->
-        let _x = scan_bool max ib in
+        let _x = scan_bool width ib in
         scan_fmt ir (stack f (token_bool ib)) (succ i)
       | 'r' ->
         if ir > limr then assert false else
@@ -1413,7 +1439,7 @@ let scan_format ib ef fmt rv f =
         match Sformat.get fmt i with
         (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *)
         | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv1 ->
-          let _x = scan_int_conv conv1 max min ib in
+          let _x = scan_int_conv conv1 width prec ib in
           (* Look back to the character that triggered the integer conversion
              (this character is either 'l', 'n' or 'L') to find the
              conversion to apply to the integer token read. *)
@@ -1423,11 +1449,6 @@ let scan_format ib ef fmt rv f =
           | _ -> scan_fmt ir (stack f (token_int64 conv1 ib)) (succ i) end
         (* This is not an integer conversion, but a regular %l, %n or %L. *)
         | _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end
-      | '!' ->
-        if Scanning.end_of_input ib then scan_fmt ir f (succ i)
-        else bad_input "end of input not found"
-      | ',' ->
-        scan_fmt ir f (succ i)
       | '(' | '{' as conv (* ')' '}' *) ->
         let i = succ i in
         (* Find the static specification for the format to read. *)
@@ -1437,7 +1458,7 @@ let scan_format ib ef fmt rv f =
         let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in
         (* Read the specified format string in the input buffer,
            and check its correctness. *)
-        let _x = scan_String max ib in
+        let _x = scan_String width ib in
         let rf = token_string ib in
         if not (compatible_format_type rf mf) then format_mismatch rf mf else
         (* For conversion %{%}, just return this format string as the token
@@ -1451,12 +1472,23 @@ let scan_format ib ef fmt rv f =
 
       | c -> bad_conversion fmt i c
 
-    and scan_fmt_stoppers i =
-      if i > lim then i - 1, [] else
-      match Sformat.get fmt i with
-      | '@' when i < lim -> let i = succ i in i, [Sformat.get fmt i]
-      | '@' when i = lim -> incomplete_format fmt
-      | _ -> i - 1, [] in
+    and scan_indication j =
+      if j > lim then j - 1, [] else
+      match Sformat.get fmt j with
+      | '@' ->
+        let k = j + 1 in
+        if k > lim then j - 1, [] else
+        begin match Sformat.get fmt k with
+        | '%' ->
+          let k = k + 1 in
+          if k > lim then j - 1, [] else
+          begin match Sformat.get fmt k with
+          | '%' | '@' as c  -> k, [ c ]
+          | _c -> j - 1, []
+          end
+        | c -> k, [ c ]
+        end
+      | _c -> j - 1, [] in
 
     scan_fmt in
 
@@ -1481,7 +1513,8 @@ let bscanf ib = kscanf ib scanf_bad_input;;
 
 let fscanf ic = bscanf (Scanning.from_channel ic);;
 
-let sscanf s = bscanf (Scanning.from_string s);;
+let sscanf : string -> ('a, 'b, 'c, 'd) scanner
+  = fun s -> bscanf (Scanning.from_string s);;
 
 let scanf fmt = bscanf Scanning.stdib fmt;;
 
@@ -1513,3 +1546,12 @@ let string_to_String s =
 let format_from_string s fmt =
   sscanf_format (string_to_String s) fmt (fun x -> x)
 ;;
+
+let unescaped s =
+  sscanf ("\"" ^ s ^ "\"") "%S%!" (fun x -> x)
+
+(*
+ Local Variables:
+  compile-command: "cd ..; make world"
+  End:
+*)

diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli
index 2a3bf4fdae694827ed3af02245ae93cb5ef0be68..c147f7a04bebaf39ee8af2544d121b57fc2acc5b 100644 (file)
--- a/stdlib/scanf.mli
+++ b/stdlib/scanf.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
@@ -25,7 +25,8 @@
     strings, files, or anything that can return characters. The more general
     source of characters is named a {e formatted input channel} (or {e
     scanning buffer}) and has type {!Scanning.in_channel}. The more general
-    formatted input function reads from any scanning buffer and is named [bscanf].
+    formatted input function reads from any scanning buffer and is named
+    [bscanf].
 
     Generally speaking, the formatted input functions have 3 arguments:
     - the first argument is a source of characters for the input,
@@ -58,30 +59,31 @@
 
     - if we define the receiver [f] as [let f x = x + 1],
 
-    then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the standard input
-    and returns [f n] (that is [n + 1]). Thus, if we evaluate [bscanf stdin
-    "%d" f], and then enter [41] at the keyboard, we get [42] as the final
-    result. *)
+    then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the
+    standard input and returns [f n] (that is [n + 1]). Thus, if we
+    evaluate [bscanf stdin "%d" f], and then enter [41] at the
+    keyboard, we get [42] as the final result. *)
 
 (** {7 Formatted input as a functional feature} *)
 
-(** The Caml scanning facility is reminiscent of the corresponding C feature.
+(** The OCaml scanning facility is reminiscent of the corresponding C feature.
     However, it is also largely different, simpler, and yet more powerful:
     the formatted input functions are higher-order functionals and the
     parameter passing mechanism is just the regular function application not
     the variable assignment based mechanism which is typical for formatted
-    input in imperative languages; the Caml format strings also feature
+    input in imperative languages; the OCaml format strings also feature
     useful additions to easily define complex tokens; as expected within a
     functional programming language, the formatted input functions also
     support polymorphism, in particular arbitrary interaction with
-    polymorphic user-defined scanners.  Furthermore, the Caml formatted input
+    polymorphic user-defined scanners.  Furthermore, the OCaml formatted input
     facility is fully type-checked at compile time. *)
 
 (** {6 Formatted input channel} *)
+
 module Scanning : sig
 
 type in_channel;;
-(* The notion of input channel for the [Scanf] module:
+(** The notion of input channel for the [Scanf] module:
    those channels provide all the machinery necessary to read from a given
    [Pervasives.in_channel] value.
    A [Scanf.Scanning.in_channel] value is also called a {i formatted input
@@ -114,7 +116,12 @@ val stdin : in_channel;;
     @since 3.12.0
 *)
 
-val open_in : string -> in_channel;;
+type file_name = string;;
+(** A convenient alias to designate a file name.
+    @since 4.00.0
+*)
+
+val open_in : file_name -> in_channel;;
 (** [Scanning.open_in fname] returns a formatted input channel for bufferized
     reading in text mode of file [fname].
 
@@ -126,9 +133,9 @@ val open_in : string -> in_channel;;
     @since 3.12.0
 *)
 
-val open_in_bin : string -> in_channel;;
-(** [Scanning.open_in_bin fname] returns a formatted input channel for bufferized
-    reading in binary mode of file [fname].
+val open_in_bin : file_name -> in_channel;;
+(** [Scanning.open_in_bin fname] returns a formatted input channel for
+    bufferized reading in binary mode of file [fname].
     @since 3.12.0
 *)
 
@@ -138,7 +145,7 @@ val close_in : in_channel -> unit;;
   @since 3.12.0
 *)
 
-val from_file : string -> in_channel;;
+val from_file : file_name -> in_channel;;
 (** An alias for [open_in] above. *)
 val from_file_bin : string -> in_channel;;
 (** An alias for [open_in_bin] above. *)
@@ -187,12 +194,13 @@ end;;
 
 type ('a, 'b, 'c, 'd) scanner =
      ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;;
-(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the
-    type of a formatted input function that reads from some formatted input channel
-    according to some format string; more precisely, if [scan] is some
-    formatted input function, then [scan ic fmt f] applies [f] to the arguments
-    specified by the format string [fmt], when [scan] has read those arguments
-    from the formatted input channel [ic].
+(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner]
+    is the type of a formatted input function that reads from some
+    formatted input channel according to some format string; more
+    precisely, if [scan] is some formatted input function, then [scan
+    ic fmt f] applies [f] to the arguments specified by the format
+    string [fmt], when [scan] has read those arguments from the
+    formatted input channel [ic].
 
     For instance, the [scanf] function below has type [('a, 'b, 'c, 'd)
     scanner], since it is a formatted input function that reads from
@@ -268,7 +276,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
        ([0x[0-9a-f]+] and [0X[0-9A-F]+]), octal ([0o[0-7]+]), and binary
        ([0b[0-1]+]) notations are understood).
     - [u]: reads an unsigned decimal integer.
-    - [x] or [X]: reads an unsigned hexadecimal integer ([[0-9a-f]+] or [[0-9A-F]+]).
+    - [x] or [X]: reads an unsigned hexadecimal integer ([[0-9a-fA-F]+]).
     - [o]: reads an unsigned octal integer ([[0-7]+]).
     - [s]: reads a string argument that spreads as much as possible, until the
       following bounding condition holds: {ul
@@ -277,20 +285,20 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
          encountered,}
       {- the end-of-input has been reached.}}
       Hence, this conversion always succeeds: it returns an empty
-      string, if the bounding condition holds when the scan begins.
+      string if the bounding condition holds when the scan begins.
     - [S]: reads a delimited string argument (delimiters and special
-      escaped characters follow the lexical conventions of Caml).
+      escaped characters follow the lexical conventions of OCaml).
     - [c]: reads a single character. To test the current input character
       without reading it, specify a null field width, i.e. use
       specification [%0c]. Raise [Invalid_argument], if the field width
       specification is greater than 1.
     - [C]: reads a single delimited character (delimiters and special
-      escaped characters follow the lexical conventions of Caml).
+      escaped characters follow the lexical conventions of OCaml).
     - [f], [e], [E], [g], [G]: reads an optionally signed
       floating-point number in decimal notation, in the style [dddd.ddd
       e/E+-dd].
     - [F]: reads a floating point number according to the lexical
-      conventions of Caml (hence the decimal point is mandatory if the
+      conventions of OCaml (hence the decimal point is mandatory if the
       exponent part is not mentioned).
     - [B]: reads a boolean argument ([true] or [false]).
     - [b]: reads a boolean argument (for backward compatibility; do not use
@@ -313,17 +321,17 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
       first character of the range (or just after the [^] in case of
       range negation); hence [\[\]\]] matches a [\]] character and
       [\[^\]\]] matches any character that is not [\]].
-    - [r]: user-defined reader. Takes the next [ri] formatted input function and
-      applies it to the scanning buffer [ib] to read the next argument. The
-      input function [ri] must therefore have type [Scanning.in_channel -> 'a] and
-      the argument read has type ['a].
-    - [\{ fmt %\}]: reads a format string argument.
-      The format string read must have the same type as the format string
-      specification [fmt].
-      For instance, ["%{ %i %}"] reads any format string that can read a value of
-      type [int]; hence, if [s] is the string ["fmt:\"number is %u\""], then
-      [Scanf.sscanf s "fmt: %{%i%}"] succeeds and returns the format string
-      ["number is %u"].
+      Use [%%] and [%\@] to include a [%] or a [\@] in a range.
+    - [r]: user-defined reader. Takes the next [ri] formatted input
+      function and applies it to the scanning buffer [ib] to read the
+      next argument. The input function [ri] must therefore have type
+      [Scanning.in_channel -> 'a] and the argument read has type ['a].
+    - [\{ fmt %\}]: reads a format string argument.  The format string
+      read must have the same type as the format string specification
+      [fmt].  For instance, ["%{ %i %}"] reads any format string that
+      can read a value of type [int]; hence, if [s] is the string
+      ["fmt:\"number is %u\""], then [Scanf.sscanf s "fmt: %{%i%}"]
+      succeeds and returns the format string ["number is %u"].
     - [\( fmt %\)]: scanning format substitution.
       Reads a format string and then goes on scanning with the format string
       read, instead of using [fmt].
@@ -347,7 +355,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     - [N] or [L]: returns the number of tokens read so far.
     - [!]: matches the end of input condition.
     - [%]: matches one [%] character in the input.
-    - [,]: the no-op delimiter for conversion specifications.
+    - [\@]: matches one [\@] character in the input.
+    - [,]: does nothing.
 
     Following the [%] character that introduces a conversion, there may be
     the special flag [_]: the conversion that follows occurs as usual,
@@ -358,7 +367,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
     The field width is composed of an optional integer literal
     indicating the maximal width of the token to read.
     For instance, [%6d] reads an integer, having at most 6 decimal digits;
-    [%4f] reads a float with at most 4 characters; and [%8\[\\000-\\255\]]
+    [%4f] reads a float with at most 4 characters; and [%8[\\000-\\255]]
     returns the next 8 characters (or all the characters still available,
     if fewer than 8 characters are available in the input).
 
@@ -368,7 +377,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
       nothing to read in the input: in this case, it simply returns [""].
 
     - in addition to the relevant digits, ['_'] characters may appear
-    inside numbers (this is reminiscent to the usual Caml lexical
+    inside numbers (this is reminiscent to the usual OCaml lexical
     conventions). If stricter scanning is desired, use the range
     conversion facility instead of the number conversions.
 
@@ -381,19 +390,22 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
 (** {7:indication Scanning indications in format strings} *)
 
 (** Scanning indications appear just after the string conversions [%s]
-    and [%\[ range \]] to delimit the end of the token. A scanning
-    indication is introduced by a [@] character, followed by some
-    constant character [c]. It means that the string token should end
+    and [%[ range ]] to delimit the end of the token. A scanning
+    indication is introduced by a [\@] character, followed by some
+    plain character [c]. It means that the string token should end
     just before the next matching [c] (which is skipped). If no [c]
     character is encountered, the string token spreads as much as
     possible. For instance, ["%s@\t"] reads a string up to the next
-    tab character or to the end of input. If a scanning
-    indication [\@c] does not follow a string conversion, it is treated
-    as a plain [c] character.
+    tab character or to the end of input. If a [\@] character appears
+    anywhere else in the format string, it is treated as a plain character.
 
     Note:
 
-    - the scanning indications introduce slight differences in the syntax of
+    - As usual in format strings, [%] characters must be escaped using [%%]
+      and [%\@] is equivalent to [\@]; this rule still holds within range
+      specifications and scanning indications.
+      For instance, ["%s@%%"] reads a string up to the next [%] character.
+    - The scanning indications introduce slight differences in the syntax of
     [Scanf] format strings, compared to those used for the [Printf]
     module. However, the scanning indications are similar to those used in
     the [Format] module; hence, when producing formatted text to be scanned
@@ -420,7 +432,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;;
 
     - as a consequence, scanning a [%s] conversion never raises exception
     [End_of_file]: if the end of input is reached the conversion succeeds and
-    simply returns the characters read so far, or [""] if none were ever read. *)
+    simply returns the characters read so far, or [""] if none were ever read.
+    *)
 
 (** {6 Specialised formatted input functions} *)
 
@@ -482,3 +495,11 @@ val format_from_string :
     have the same type as [fmt].
     @since 3.10.0
 *)
+
+val unescaped : string -> string
+(** Return a copy of the argument with escape sequences, following the
+    lexical conventions of OCaml, replaced by their corresponding
+    special characters.  If there is no escape sequence in the
+    argument, still return a copy, contrary to String.escaped.
+    @since 4.00.0
+*)

diff --git a/stdlib/set.ml b/stdlib/set.ml
index 375fc5d0e4dac8bda32a08413ec63f969eb852e1..e61fd24b6a0e6e68cd0c342c1538e8127296ac46 100644 (file)
--- a/stdlib/set.ml
+++ b/stdlib/set.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -117,13 +117,32 @@ module Make(Ord: OrderedType) =
           if c = 0 then t else
           if c < 0 then bal (add x l) v r else bal l v (add x r)
 
+    let singleton x = Node(Empty, x, Empty, 1)
+
+    (* Beware: those two functions assume that the added v is *strictly*
+       smaller (or bigger) than all the present elements in the tree; it
+       does not test for equality with the current min (or max) element.
+       Indeed, they are only used during the "join" operation which
+       respects this precondition.
+    *)
+
+    let rec add_min_element v = function
+      | Empty -> singleton v
+      | Node (l, x, r, h) ->
+        bal (add_min_element v l) x r
+
+    let rec add_max_element v = function
+      | Empty -> singleton v
+      | Node (l, x, r, h) ->
+        bal l x (add_max_element v r)
+
     (* Same as create and bal, but no assumptions are made on the
        relative heights of l and r. *)
 
     let rec join l v r =
       match (l, r) with
-        (Empty, _) -> add v r
-      | (_, Empty) -> add v l
+        (Empty, _) -> add_min_element v r
+      | (_, Empty) -> add_max_element v l
       | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
           if lh > rh + 2 then bal ll lv (join lr v r) else
           if rh > lh + 2 then bal (join l v rl) rv rr else
@@ -197,8 +216,6 @@ module Make(Ord: OrderedType) =
           let c = Ord.compare x v in
           c = 0 || mem x (if c < 0 then l else r)
 
-    let singleton x = Node(Empty, x, Empty, 1)
-
     let rec remove x = function
         Empty -> Empty
       | Node(l, v, r, _) ->
@@ -300,19 +317,19 @@ module Make(Ord: OrderedType) =
         Empty -> false
       | Node(l, v, r, _) -> p v || exists p l || exists p r
 
-    let filter p s =
-      let rec filt accu = function
-        | Empty -> accu
-        | Node(l, v, r, _) ->
-            filt (filt (if p v then add v accu else accu) l) r in
-      filt Empty s
-
-    let partition p s =
-      let rec part (t, f as accu) = function
-        | Empty -> accu
-        | Node(l, v, r, _) ->
-            part (part (if p v then (add v t, f) else (t, add v f)) l) r in
-      part (Empty, Empty) s
+    let rec filter p = function
+        Empty -> Empty
+      | Node(l, v, r, _) ->
+          let l' = filter p l and r' = filter p r in
+          if p v then join l' v r' else concat l' r'
+
+    let rec partition p = function
+        Empty -> (Empty, Empty)
+      | Node(l, v, r, _) ->
+          let (lt, lf) = partition p l and (rt, rf) = partition p r in
+          if p v
+          then (join lt v rt, concat lf rf)
+          else (concat lt rt, join lf v rf)
 
     let rec cardinal = function
         Empty -> 0

diff --git a/stdlib/set.mli b/stdlib/set.mli
index 851a9ef51c76babe742c9a785e15095964f17779..0f1a3b7c96a3626e5e5109ef9e80e64b283755cb 100644 (file)
--- a/stdlib/set.mli
+++ b/stdlib/set.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/sort.ml b/stdlib/sort.ml
index 7c53ab777499d25bcdbff9c46cc5bb1980c80c32..66546b12b184623990ee9714b8956b195135b864 100644 (file)
--- a/stdlib/sort.ml
+++ b/stdlib/sort.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/sort.mli b/stdlib/sort.mli
index 7069052eb4711e29966617433487184aaa5558a3..4f2a961aaaeb39182a598b724bded05d723b4c21 100644 (file)
--- a/stdlib/sort.mli
+++ b/stdlib/sort.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/stack.ml b/stdlib/stack.ml
index 03277d0794d0f362b3739a3509dce90315018e22..599b10c8bb4609afc6f0ecaf56c356f5e8f2e954 100644 (file)
--- a/stdlib/stack.ml
+++ b/stdlib/stack.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/stack.mli b/stdlib/stack.mli
index bf33d01aba95cba218a6223c78403a14f7641ce2..2d7a90066add3d73710acbd9826506abada7330d 100644 (file)
--- a/stdlib/stack.mli
+++ b/stdlib/stack.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/stdLabels.ml b/stdlib/stdLabels.ml
index bd6a5841de6a8c22bc8da3d06ae3c1ea81d58825..468dd5176e619c14d48ffbf93fee3813862a7a4c 100644 (file)
--- a/stdlib/stdLabels.ml
+++ b/stdlib/stdLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)

diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli
index 73f72dc6874f0659d53ef5d8ed98c8b64b6d4edd..1360081a22877027b3f8780455f484cea511616b 100644 (file)
--- a/stdlib/stdLabels.mli
+++ b/stdlib/stdLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)
@@ -117,6 +117,7 @@ module String :
         unit
     val concat : sep:string -> string list -> string
     val iter : f:(char -> unit) -> string -> unit
+    val trim : string -> string
     val escaped : string -> string
     val index : string -> char -> int
     val rindex : string -> char -> int

diff --git a/stdlib/std_exit.ml b/stdlib/std_exit.ml
index 6f5ff301aa089f60cf9008416e04eb671cc79709..c56153738fd9192f43aa6d190a7f98212e57a832 100644 (file)
--- a/stdlib/std_exit.ml
+++ b/stdlib/std_exit.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/stdlib/stream.ml b/stdlib/stream.ml
index aa6a2a2ab263a0b3d26a91a55f092f8fef1f5ea6..fc66acb3e96b8c58d4adcd3aaf4b92a4f7470355 100644 (file)
--- a/stdlib/stream.ml
+++ b/stdlib/stream.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                             Ocaml                                   *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)

diff --git a/stdlib/stream.mli b/stdlib/stream.mli
index 28cfd3a1c4e9e37722fb8c56030aac99ad1e67e5..16e71179734e984ac3174d046967692bb8a08ff8 100644 (file)
--- a/stdlib/stream.mli
+++ b/stdlib/stream.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                             Ocaml                                   *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*        Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt     *)
 (*                                                                     *)
@@ -27,12 +27,7 @@ exception Error of string
    accepted, but one of the following components is rejected. *)
 
 
-(** {6 Stream builders}
-
-   Warning: these functions create streams with fast access; it is illegal
-   to mix them with streams built with [[< >]]; would raise [Failure]
-   when accessing such mixed streams.
-*)
+(** {6 Stream builders} *)
 
 val from : (int -> 'a option) -> 'a t
 (** [Stream.from f] returns a stream built from the function [f].
@@ -90,7 +85,7 @@ val npeek : int -> 'a t -> 'a list
 
 (**/**)
 
-(** {6 For system use only, not for the casual user} *)
+(* The following is for system use only. Do not call directly. *)
 
 val iapp : 'a t -> 'a t -> 'a t
 val icons : 'a -> 'a t -> 'a t

diff --git a/stdlib/string.ml b/stdlib/string.ml
index 0e55ff460722e7332d038d2109584688b3a9a156..f3906f3533bb3ae1ad2b31935b7f672c89eaa13e 100644 (file)
--- a/stdlib/string.ml
+++ b/stdlib/string.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -60,6 +60,9 @@ let blit s1 ofs1 s2 ofs2 len =
 let iter f a =
   for i = 0 to length a - 1 do f(unsafe_get a i) done
 
+let iteri f a =
+  for i = 0 to length a - 1 do f i (unsafe_get a i) done
+
 let concat sep l =
   match l with
     [] -> ""
@@ -82,6 +85,27 @@ external is_printable: char -> bool = "caml_is_printable"
 external char_code: char -> int = "%identity"
 external char_chr: int -> char = "%identity"
 
+let is_space = function
+  | ' ' | '\012' | '\n' | '\r' | '\t' -> true
+  | _ -> false
+
+let trim s =
+  let len = length s in
+  let i = ref 0 in
+  while !i < len && is_space (unsafe_get s !i) do
+    incr i
+  done;
+  let j = ref (len - 1) in
+  while !j >= !i && is_space (unsafe_get s !j) do
+    decr j
+  done;
+  if !i = 0 && !j = len - 1 then
+    s
+  else if !j >= !i then
+    sub s !i (!j - !i + 1)
+  else
+    ""
+
 let escaped s =
   let n = ref 0 in
     for i = 0 to length s - 1 do

diff --git a/stdlib/string.mli b/stdlib/string.mli
index 21bfb7c0e1987e9b1aa829ee88c3f602fce8bb2c..c248fab18a443fa6b10e92d6bb8fed2b540e991c 100644 (file)
--- a/stdlib/string.mli
+++ b/stdlib/string.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -14,6 +14,7 @@
 (* $Id$ *)
 
 (** String operations.
+
   Given a string [s] of length [l], we call character number in [s]
   the index of a character in [s].  Indexes start at [0], and we will
   call a character number valid in [s] if it falls within the range
@@ -25,6 +26,31 @@
   Two parameters [start] and [len] are said to designate a valid
   substring of [s] if [len >= 0] and [start] and [start+len] are
   valid positions in [s].
+
+  OCaml strings can be modified in place, for instance via the
+  {!String.set} and {!String.blit} functions described below.  This
+  possibility should be used rarely and with much care, however, since
+  both the OCaml compiler and most OCaml libraries share strings as if
+  they were immutable, rather than copying them.  In particular,
+  string literals are shared: a single copy of the string is created
+  at program loading time and returned by all evaluations of the
+  string literal.  Consider for example:
+
+  {[
+      # let f () = "foo";;
+      val f : unit -> string = <fun>
+      # (f ()).[0] <- 'b';;
+      - : unit = ()
+      # f ();;
+      - : string = "boo"
+  ]}
+
+  Likewise, many functions from the standard library can return string
+  literals or one of their string arguments.  Therefore, the returned strings
+  must not be modified directly.  If mutation is absolutely necessary,
+  it should be performed on a fresh copy of the string, as produced by
+  {!String.copy}.
+
  *)
 
 external length : string -> int = "%string_length"
@@ -94,12 +120,33 @@ val iter : (char -> unit) -> string -> unit
    the characters of [s].  It is equivalent to
    [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *)
 
+val iteri : (int -> char -> unit) -> string -> unit
+(** Same as {!String.iter}, but the
+   function is applied to the index of the element as first argument
+   (counting from 0), and the character itself as second argument.
+   @since 4.00.0
+*)
+
+val map : (char -> char) -> string -> string
+(** [String.map f s] applies function [f] in turn to all
+   the characters of [s] and stores the results in a new string that
+   is returned.
+   @since 4.00.0 *)
+
+val trim : string -> string
+(** Return a copy of the argument, without leading and trailing
+   whitespace.  The characters regarded as whitespace are: [' '],
+   ['\012'], ['\n'], ['\r'], and ['\t'].  If there is no leading nor
+   trailing whitespace character in the argument, return the original
+   string itself, not a copy.
+   @since 4.00.0 *)
+
 val escaped : string -> string
 (** Return a copy of the argument, with special characters
    represented by escape sequences, following the lexical
-   conventions of Objective Caml.  If there is no special
+   conventions of OCaml.  If there is no special
    character in the argument, return the original string itself,
-   not a copy. *)
+   not a copy. Its inverse function is Scanf.unescaped. *)
 
 val index : string -> char -> int
 (** [String.index s c] returns the character number of the first
@@ -176,6 +223,8 @@ val compare: t -> t -> int
 
 (**/**)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_get : string -> int -> char = "%string_unsafe_get"
 external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
 external unsafe_blit :

diff --git a/stdlib/stringLabels.ml b/stdlib/stringLabels.ml
index 87d23d86fcfedbbb8944d2c1c9680519b6019100..2345d4992c73959fbd3dd2d5c74655b424b49320 100644 (file)
--- a/stdlib/stringLabels.ml
+++ b/stdlib/stringLabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*               Jacques Garrigue, Kyoto University RIMS               *)
 (*                                                                     *)

diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli
index 9cbee708bbdf746d7f965be4df0f20d54b0b0955..59b0eb7c28113a97697366a6269d61fad23172d0 100644 (file)
--- a/stdlib/stringLabels.mli
+++ b/stdlib/stringLabels.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -84,10 +84,30 @@ val iter : f:(char -> unit) -> string -> unit
    the characters of [s].  It is equivalent to
    [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *)
 
+val iteri : f:(int -> char -> unit) -> string -> unit
+(** Same as {!String.iter}, but the
+   function is applied to the index of the element as first argument
+   (counting from 0), and the character itself as second argument.
+   @since 4.00.0
+*)
+
+val map : f:(char -> char) -> string -> string
+(** [String.map f s] applies function [f] in turn to all
+   the characters of [s] and stores the results in a new string that
+   is returned.
+   @since 4.00.0 *)
+
+val trim : string -> string
+(** Return a copy of the argument, without leading and trailing whitespace.
+   The characters regarded as whitespace are: [' '], ['\012'], ['\n'],
+   ['\r'], and ['\t'].  If there is no whitespace character in the argument,
+   return the original string itself, not a copy.
+   @since 4.00.0 *)
+
 val escaped : string -> string
 (** Return a copy of the argument, with special characters
    represented by escape sequences, following the lexical
-   conventions of Objective Caml.  If there is no special
+   conventions of OCaml.  If there is no special
    character in the argument, return the original string itself,
    not a copy. *)
 
@@ -155,6 +175,8 @@ val compare: t -> t -> int
 
 (**/**)
 
+(* The following is for system use only. Do not call directly. *)
+
 external unsafe_get : string -> int -> char = "%string_unsafe_get"
 external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set"
 external unsafe_blit :

diff --git a/stdlib/sys.mli b/stdlib/sys.mli
index 713038aa7a85fc3c7257dff991c0a7734870dbcb..6f3d57978516793ef4165e4560f8676aca89cda0 100644 (file)
--- a/stdlib/sys.mli
+++ b/stdlib/sys.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -75,15 +75,19 @@ val interactive : bool ref
    the interactive toplevel system [ocaml]. *)
 
 val os_type : string
-(** Operating system currently executing the Caml program. One of
+(** Operating system currently executing the OCaml program. One of
 -  ["Unix"] (for all Unix versions, including Linux and Mac OS X),
 -  ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw),
 -  ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). *)
 
 val word_size : int
-(** Size of one word on the machine currently executing the Caml
+(** Size of one word on the machine currently executing the OCaml
    program, in bits: 32 or 64. *)
 
+val big_endian : bool
+(** Whether the machine currently executing the Caml program is big-endian.
+    @since 4.00.0 *)
+
 val max_string_length : int
 (** Maximum length of a string. *)
 
@@ -199,7 +203,7 @@ val catch_break : bool -> unit
 
 
 val ocaml_version : string;;
-(** [ocaml_version] is the version of Objective Caml.
+(** [ocaml_version] is the version of OCaml.
     It is a string of the form ["major.minor[.patchlevel][+additional-info]"],
     where [major], [minor], and [patchlevel] are integers, and
     [additional-info] is an arbitrary string. The [[.patchlevel]] and

diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp
index b58ca0bb3a63740e6fb664f42daab91af58dad2b..c7271794d073fa12554d6c2ccf97aa4308448b4b 100644 (file)
--- a/stdlib/sys.mlp
+++ b/stdlib/sys.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,11 +19,11 @@
 
 (* System interface *)
 
-external get_config: unit -> string * int = "caml_sys_get_config"
+external get_config: unit -> string * int * bool = "caml_sys_get_config"
 external get_argv: unit -> string * string array = "caml_sys_get_argv"
 
 let (executable_name, argv) = get_argv()
-let (os_type, word_size) = get_config()
+let (os_type, word_size, big_endian) = get_config()
 let max_array_length = (1 lsl (word_size - 10)) - 1;;
 let max_string_length = word_size / 8 * max_array_length - 1;;
 

diff --git a/stdlib/weak.ml b/stdlib/weak.ml
index 4adacd8e4a7a3e6ec71ad8e3c0cde578b4df5f97..bbd3debc44acad6e52a4a0c88817d3871e6c0f3e 100644 (file)
--- a/stdlib/weak.ml
+++ b/stdlib/weak.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)

diff --git a/stdlib/weak.mli b/stdlib/weak.mli
index 33f4bf1d0ce07401e449ca48c877bcbb7b833539..add9b0abb22f9858648e17ca7f0bccd7a6b0ef95 100644 (file)
--- a/stdlib/weak.mli
+++ b/stdlib/weak.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Damien Doligez, projet Para, INRIA Rocquencourt          *)
 (*                                                                     *)

diff --git a/testlabl/.cvsignore b/testlabl/.cvsignore
deleted file mode 100644 (file)
index 4c57147..0000000
--- a/testlabl/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.out *.out2
\ No newline at end of file

diff --git a/testlabl/coerce.diffs b/testlabl/coerce.diffs
deleted file mode 100644 (file)
index e90e1fc..0000000
--- a/testlabl/coerce.diffs
+++ /dev/null
@@ -1,93 +0,0 @@
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.201
-diff -u -r1.201 ctype.ml
---- typing/ctype.ml    5 Apr 2006 02:28:13 -0000       1.201
-+++ typing/ctype.ml    17 May 2006 23:48:22 -0000
-@@ -490,6 +490,31 @@
-     unmark_class_signature sign;
-     Some reason
- 
-+(* Variant for checking principality *)
-+
-+let rec free_nodes_rec ty =
-+  let ty = repr ty in
-+  if ty.level >= lowest_level then begin
-+    if ty.level <= !current_level then raise Exit;
-+    ty.level <- pivot_level - ty.level;
-+    begin match ty.desc with
-+      Tvar ->
-+        raise Exit
-+    | Tobject (ty, _) ->
-+        free_nodes_rec ty
-+    | Tfield (_, _, ty1, ty2) ->
-+        free_nodes_rec ty1; free_nodes_rec ty2
-+    | Tvariant row ->
-+        let row = row_repr row in
-+        iter_row free_nodes_rec {row with row_bound = []};
-+        if not (static_row row) then free_nodes_rec row.row_more
-+    | _    ->
-+        iter_type_expr free_nodes_rec ty
-+    end;
-+  end
-+
-+let has_free_nodes ty =
-+  try free_nodes_rec ty; false with Exit -> true
- 
-                             (**********************)
-                             (*  Type duplication  *)
-Index: typing/ctype.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
-retrieving revision 1.54
-diff -u -r1.54 ctype.mli
---- typing/ctype.mli   5 Apr 2006 02:28:13 -0000       1.54
-+++ typing/ctype.mli   17 May 2006 23:48:22 -0000
-@@ -228,6 +228,9 @@
- val closed_class:
-         type_expr list -> class_signature -> closed_class_failure option
-         (* Check whether all type variables are bound *)
-+val has_free_nodes: type_expr -> bool
-+        (* Check whether there are free type variables, or nodes with
-+           level lower or equal to !current_level *)
- 
- val unalias: type_expr -> type_expr
- val signature_of_class_type: class_type -> class_signature
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.181
-diff -u -r1.181 typecore.ml
---- typing/typecore.ml 16 Apr 2006 23:28:22 -0000      1.181
-+++ typing/typecore.ml 17 May 2006 23:48:22 -0000
-@@ -1183,12 +1183,29 @@
-             let (ty', force) =
-               Typetexp.transl_simple_type_delayed env sty'
-             in
-+            if !Clflags.principal then begin_def ();
-             let arg = type_exp env sarg in
-+            let has_fv =
-+              if !Clflags.principal then begin
-+                end_def ();
-+                let b = has_free_nodes arg.exp_type in
-+                Ctype.unify env arg.exp_type (newvar ());
-+                b
-+              end else
-+                free_variables arg.exp_type <> []
-+            in
-             begin match arg.exp_desc, !self_coercion, (repr ty').desc with
-               Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
-               Tconstr(path',_,_) when Path.same path path' ->
-                 r := sexp.pexp_loc :: !r;
-                 force ()
-+            | _ when not has_fv ->
-+                begin try
-+                  let force' = subtype env arg.exp_type ty' in
-+                  force (); force' ()
-+                with Subtype (tr1, tr2) ->
-+                  raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
-+                end
-             | _ ->
-                 let ty, b = enlarge_type env ty' in
-                 force ();

diff --git a/testlabl/dirs_multimatch b/testlabl/dirs_multimatch
deleted file mode 100644 (file)
index b449514..0000000
--- a/testlabl/dirs_multimatch
+++ /dev/null
@@ -1 +0,0 @@
-parsing typing bytecomp driver toplevel
\ No newline at end of file

diff --git a/testlabl/dirs_poly b/testlabl/dirs_poly
deleted file mode 100644 (file)
index 3aec606..0000000
--- a/testlabl/dirs_poly
+++ /dev/null
@@ -1 +0,0 @@
-bytecomp byterun driver parsing stdlib tools toplevel typing utils otherlibs/labltk/browser/searchpos.ml

diff --git a/testlabl/els.ml b/testlabl/els.ml
deleted file mode 100644 (file)
index fdd292d..0000000
--- a/testlabl/els.ml
+++ /dev/null
@@ -1,92 +0,0 @@
-(* Adapted from: An Expressive Language of Signatures
-   by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
-
-module type VALUE = sig
-  type value (* a Lua value *)
-  type state (* the state of a Lua interpreter *)
-  type usert (* a user-defined value *)
-end
-
-module type CORE0 = sig
-  module V : VALUE
-  val setglobal : V.state -> string -> V.value -> unit
-  (* five more functions common to core and evaluator *)
-end
-
-module type CORE = sig
-  include CORE0
-  val apply : V.value -> V.state -> V.value list -> V.value
-  (* apply function f in state s to list of args *)
-end
-
-module type AST = sig
-  module Value : VALUE
-  type chunk
-  type program
-  val get_value : chunk -> Value.value
-end
-
-module type EVALUATOR = sig
-  module Value : VALUE
-  module Ast : (AST with module Value := Value)
-  type state = Value.state
-  type value = Value.value
-  exception Error of string
-  val compile : Ast.program -> string
-  include CORE0 with module V := Value
-end
-
-module type PARSER = sig
-  type chunk
-  val parse : string -> chunk
-end
-
-module type INTERP = sig
-  include EVALUATOR
-  module Parser : PARSER with type chunk = Ast.chunk
-  val dostring : state -> string -> value list
-  val mk       : unit -> state
-end
-
-module type USERTYPE = sig
-  type t
-  val eq       : t -> t -> bool
-  val to_string : t -> string
-end
-
-module type TYPEVIEW = sig
-  type combined
-  type t
-  val map : (combined -> t) * (t -> combined)
-end
-
-module type COMBINED_COMMON = sig
-  module T : sig type t end
-  module TV1 : TYPEVIEW with type combined := T.t
-  module TV2 : TYPEVIEW with type combined := T.t
-end
-
-module type COMBINED_TYPE = sig
-  module T : USERTYPE
-  include COMBINED_COMMON with module T := T
-end
-
-module type BARECODE = sig
-  type state
-  val init : state -> unit
-end
-
-module USERCODE(X : TYPEVIEW) = struct
-  module type F =
-      functor (C : CORE with type V.usert = X.combined) ->
-        BARECODE with type state := C.V.state
-end
-
-module Weapon = struct type t end
-
-module type WEAPON_LIB = sig
-  type t = Weapon.t
-  module T : USERTYPE with type t = t
-  module Make :
-    functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F
-end

diff --git a/testlabl/fixedtypes.ml b/testlabl/fixedtypes.ml
deleted file mode 100644 (file)
index a7d7ca4..0000000
--- a/testlabl/fixedtypes.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(* cvs update -r fixedtypes parsing typing *)
-
-(* recursive types *)
-class c = object (self) method m = 1 method s = self end
-module type S = sig type t = private #c end;;
-
-module M : S = struct type t = c end
-module type S' = S with type t = c;;
-
-class d = object inherit c method n = 2 end
-module type S2 = S with type t = private #d;;
-module M2 : S = struct type t = d end;;
-module M3 : S = struct type t = private #d end;;
-
-module T1 = struct
-  type ('a,'b) a = [`A of 'a | `B of 'b]
-  type ('a,'b) b = [`Z | ('a,'b) a]
-end
-module type T2 = sig
-  type a and b
-  val evala : a -> int
-  val evalb : b -> int
-end
-module type T3 = sig
-  type a0 = private [> (a0,b0) T1.a]
-  and b0 = private [> (a0,b0) T1.b]
-end
-module type T4 = sig
-  include T3
-  include T2 with type a = a0 and type b = b0
-end
-module F(X:T4) = struct
-  type a = X.a and b = X.b
-  let a = X.evala (`B `Z)
-  let b = X.evalb (`A(`B `Z))
-  let a2b (x : a) : b = `A x
-  let b2a (x : b) : a = `B x
-end
-module M4 = struct
-  type a = [`A of a | `B of b | `ZA]
-  and b = [`A of a | `B of b | `Z]
-  type a0 = a
-  type b0 = b
-  let rec eval0 = function
-      `A a -> evala a
-    | `B b -> evalb b
-  and evala : a -> int = function
-      #T1.a as x -> 1 + eval0 x
-    | `ZA -> 3
-  and evalb : b -> int = function
-      #T1.a as x -> 1 + eval0 x
-    | `Z -> 7
-end
-module M5 = F(M4)
-
-module M6 : sig
-  class ci : int ->
-    object
-      val x : int
-      method x : int
-      method move : int -> unit
-    end      
-  type c = private #ci
-  val create : int -> c
-end = struct
-  class ci x = object
-    val mutable x : int = x
-    method x = x
-    method move d = x <- x+d
-  end
-  type c = ci
-  let create = new ci
-end
-let f (x : M6.c) = x#move 3; x#x;;
-
-module M : sig type t = private [> `A of bool] end =
-  struct type t = [`A of int] end

diff --git a/testlabl/marshal_objects.diffs b/testlabl/marshal_objects.diffs
deleted file mode 100644 (file)
index bb9b4dd..0000000
--- a/testlabl/marshal_objects.diffs
+++ /dev/null
@@ -1,800 +0,0 @@
-? bytecomp/alpha_eq.ml
-Index: bytecomp/lambda.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v
-retrieving revision 1.44
-diff -u -r1.44 lambda.ml
---- bytecomp/lambda.ml 25 Aug 2005 15:35:16 -0000      1.44
-+++ bytecomp/lambda.ml 2 Feb 2006 05:08:56 -0000
-@@ -287,9 +287,10 @@
-     let compare = compare
-   end)
- 
--let free_ids get l =
-+let free_ids get used l =
-   let fv = ref IdentSet.empty in
-   let rec free l =
-+    let old = !fv in
-     iter free l;
-     fv := List.fold_right IdentSet.add (get l) !fv;
-     match l with
-@@ -307,17 +308,20 @@
-         fv := IdentSet.remove v !fv
-     | Lassign(id, e) ->
-         fv := IdentSet.add id !fv
-+    | Lifused(id, e) ->
-+        if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv
-     | Lvar _ | Lconst _ | Lapply _
-     | Lprim _ | Lswitch _ | Lstaticraise _
-     | Lifthenelse _ | Lsequence _ | Lwhile _
--    | Lsend _ | Levent _ | Lifused _ -> ()
-+    | Lsend _ | Levent _ -> ()
-   in free l; !fv
- 
--let free_variables l =
--  free_ids (function Lvar id -> [id] | _ -> []) l
-+let free_variables ?(ifused=false) l =
-+  free_ids (function Lvar id -> [id] | _ -> []) ifused l
- 
- let free_methods l =
--  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
-+  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> [])
-+    false l
- 
- (* Check if an action has a "when" guard *)
- let raise_count = ref 0
-Index: bytecomp/lambda.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v
-retrieving revision 1.42
-diff -u -r1.42 lambda.mli
---- bytecomp/lambda.mli        25 Aug 2005 15:35:16 -0000      1.42
-+++ bytecomp/lambda.mli        2 Feb 2006 05:08:56 -0000
-@@ -177,7 +177,7 @@
- 
- val iter: (lambda -> unit) -> lambda -> unit
- module IdentSet: Set.S with type elt = Ident.t
--val free_variables: lambda -> IdentSet.t
-+val free_variables: ?ifused:bool -> lambda -> IdentSet.t
- val free_methods: lambda -> IdentSet.t
- 
- val transl_path: Path.t -> lambda
-Index: bytecomp/translclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
-retrieving revision 1.38
-diff -u -r1.38 translclass.ml
---- bytecomp/translclass.ml    13 Aug 2005 20:59:37 -0000      1.38
-+++ bytecomp/translclass.ml    2 Feb 2006 05:08:56 -0000
-@@ -46,6 +46,10 @@
- 
- let lfield v i = Lprim(Pfield i, [Lvar v])
- 
-+let ltuple l = Lprim(Pmakeblock(0,Immutable), l)
-+
-+let lprim name args = Lapply(oo_prim name, args)
-+
- let transl_label l = share (Const_immstring l)
- 
- let rec transl_meth_list lst =
-@@ -68,8 +72,8 @@
-                                                     Lvar offset])])]))
- 
- let transl_val tbl create name =
--  Lapply (oo_prim (if create then "new_variable" else "get_variable"),
--          [Lvar tbl; transl_label name])
-+  lprim (if create then "new_variable" else "get_variable")
-+    [Lvar tbl; transl_label name]
- 
- let transl_vals tbl create vals rem =
-   List.fold_right
-@@ -82,7 +86,7 @@
-     (fun (nm, id) rem ->
-        try
-          (nm, id,
--          Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
-+          lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)])
-          :: rem
-        with Not_found -> rem)
-     inh_meths []
-@@ -97,17 +101,15 @@
-   let (inh_init, obj_init, has_init) = init obj' in
-   if obj_init = lambda_unit then
-     (inh_init,
--     Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
--                      else"create_object_opt"),
--             [obj; Lvar cl]))
-+     lprim (if has_init then "create_object_and_run_initializers"
-+            else"create_object_opt")
-+       [obj; Lvar cl])
-   else begin
-    (inh_init,
--    Llet(Strict, obj',
--            Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
-+    Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl],
-          Lsequence(obj_init,
-                    if not has_init then Lvar obj' else
--                   Lapply (oo_prim "run_initializers_opt",
--                         [obj; Lvar obj'; Lvar cl]))))
-+                   lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl])))
-   end
- 
- let rec build_object_init cl_table obj params inh_init obj_init cl =
-@@ -203,14 +205,13 @@
- 
- 
- let bind_method tbl lab id cl_init =
--  Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
--                              [Lvar tbl; transl_label lab]),
-+  Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab],
-        cl_init)
- 
--let bind_methods tbl meths vals cl_init =
--  let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
-+let bind_methods tbl methl vals cl_init =
-   let len = List.length methl and nvals = List.length vals in
--  if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
-+  if len < 2 && nvals = 0 then
-+    List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else
-   if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
-   let ids = Ident.create "ids" in
-   let i = ref len in
-@@ -229,21 +230,19 @@
-              vals' cl_init)
-   in
-   Llet(StrictOpt, ids,
--       Lapply (oo_prim getter,
--               [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
-+       lprim getter
-+         ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
-        List.fold_right
--         (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
-+         (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam))
-          methl cl_init)
- 
- let output_methods tbl methods lam =
-   match methods with
-     [] -> lam
-   | [lab; code] ->
--      lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
-+      lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam
-   | _ ->
--      lsequence (Lapply(oo_prim "set_methods",
--                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
--        lam
-+      lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam
- 
- let rec ignore_cstrs cl =
-   match cl.cl_desc with
-@@ -266,7 +265,8 @@
-            Llet (Strict, obj_init, 
-                  Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
-                       if top then [Lprim(Pfield 3, [lpath])] else []),
--                 bind_super cla super cl_init))
-+                 bind_super cla super cl_init),
-+           [], [])
-       | _ ->
-           assert false
-       end
-@@ -278,10 +278,11 @@
-             match field with
-               Cf_inher (cl, vals, meths) ->
-                 let cl_init = output_methods cla methods cl_init in
--                let inh_init, cl_init =
-+                let (inh_init, cl_init, meths', vals') =
-                   build_class_init cla false
-                     (vals, meths_super cla str.cl_meths meths)
-                     inh_init cl_init msubst top cl in
-+                let cl_init = bind_methods cla meths' vals' cl_init in
-                 (inh_init, cl_init, [], values)
-             | Cf_val (name, id, exp) ->
-                 (inh_init, cl_init, methods, (name, id)::values)
-@@ -304,29 +305,37 @@
-                 (inh_init, cl_init, methods, vals @ values)
-             | Cf_init exp ->
-                 (inh_init,
--                 Lsequence(Lapply (oo_prim "add_initializer",
--                                   Lvar cla :: msubst false (transl_exp exp)),
-+                 Lsequence(lprim "add_initializer"
-+                             (Lvar cla :: msubst false (transl_exp exp)),
-                            cl_init),
-                  methods, values))
-           str.cl_field
-           (inh_init, cl_init, [], [])
-       in
-       let cl_init = output_methods cla methods cl_init in
--      (inh_init, bind_methods cla str.cl_meths values cl_init)
-+      (* inh_init, bind_methods cla str.cl_meths values cl_init *)
-+      let methods =  Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in
-+      (inh_init, cl_init, methods, values)
-   | Tclass_fun (pat, vals, cl, _) ->
--      let (inh_init, cl_init) =
-+      let (inh_init, cl_init, methods, values) =
-         build_class_init cla cstr super inh_init cl_init msubst top cl
-       in
-+      let fv = free_variables ~ifused:true cl_init in
-+      let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
-       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
--      (inh_init, transl_vals cla true vals cl_init)
-+      (* inh_init, transl_vals cla true vals cl_init *)
-+      (inh_init, cl_init, methods, vals @ values)
-   | Tclass_apply (cl, exprs) ->
-       build_class_init cla cstr super inh_init cl_init msubst top cl
-   | Tclass_let (rec_flag, defs, vals, cl) ->
--      let (inh_init, cl_init) =
-+      let (inh_init, cl_init, methods, values) =
-         build_class_init cla cstr super inh_init cl_init msubst top cl
-       in
-+      let fv = free_variables ~ifused:true cl_init in
-+      let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
-       let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
--      (inh_init, transl_vals cla true vals cl_init)
-+      (* inh_init, transl_vals cla true vals cl_init *)
-+      (inh_init, cl_init, methods, vals @ values)
-   | Tclass_constraint (cl, vals, meths, concr_meths) ->
-       let virt_meths =
-         List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
-@@ -358,23 +367,34 @@
-               cl_init valids in
-           (inh_init,
-            Llet (Strict, inh, 
--               Lapply(oo_prim "inherits", narrow_args @
--                      [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
-+               lprim "inherits"
-+                   (narrow_args @
-+                    [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
-                  Llet(StrictOpt, obj_init, lfield inh 0,
-                  Llet(Alias, inh_vals, lfield inh 1,
--                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
-+                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))),
-+          [], [])
-       | _ ->
-         let core cl_init =
-             build_class_init cla true super inh_init cl_init msubst top cl
-         in
-         if cstr then core cl_init else
--          let (inh_init, cl_init) =
--            core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
-+          let (inh_init, cl_init, methods, values) =
-+            core (Lsequence (lprim "widen" [Lvar cla], cl_init))
-           in
--          (inh_init,
--           Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
-+          let cl_init = bind_methods cla methods values cl_init in
-+          (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], [])
-       end
- 
-+let build_class_init cla env inh_init obj_init msubst top cl =
-+  let inh_init = List.rev inh_init in
-+  let (inh_init, cl_init, methods, values) =
-+    build_class_init cla true ([],[]) inh_init obj_init msubst top cl in
-+  assert (inh_init = []);
-+  if IdentSet.mem env (free_variables ~ifused:true cl_init)
-+  then bind_methods cla methods (("", env) :: values) cl_init
-+  else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init)
-+
- let rec build_class_lets cl =
-   match cl.cl_desc with
-     Tclass_let (rec_flag, defs, vals, cl) ->
-@@ -459,16 +479,16 @@
-     Strict, new_init, lfunction [obj_init] obj_init',
-     Llet(
-     Alias, cla, transl_path path,
--    Lprim(Pmakeblock(0, Immutable),
--          [Lapply(Lvar new_init, [lfield cla 0]);
--           lfunction [table]
--             (Llet(Strict, env_init,
--                   Lapply(lfield cla 1, [Lvar table]),
--                   lfunction [envs]
--                     (Lapply(Lvar new_init,
--                             [Lapply(Lvar env_init, [Lvar envs])]))));
--           lfield cla 2;
--           lfield cla 3])))
-+    ltuple
-+      [Lapply(Lvar new_init, [lfield cla 0]);
-+       lfunction [table]
-+         (Llet(Strict, env_init,
-+               Lapply(lfield cla 1, [Lvar table]),
-+               lfunction [envs]
-+                 (Lapply(Lvar new_init,
-+                         [Lapply(Lvar env_init, [Lvar envs])]))));
-+       lfield cla 2;
-+       lfield cla 3]))
-   with Exit ->
-     lambda_unit
- 
-@@ -541,7 +561,7 @@
-   open CamlinternalOO
-   let builtin_meths arr self env env2 body =
-     let builtin, args = builtin_meths self env env2 body in
--    if not arr then [Lapply(oo_prim builtin, args)] else
-+    if not arr then [lprim builtin args] else
-     let tag = match builtin with
-       "get_const" -> GetConst
-     | "get_var"   -> GetVar
-@@ -599,7 +619,8 @@
- 
-   (* Prepare for heavy environment handling *)
-   let tables = Ident.create (Ident.name cl_id ^ "_tables") in
--  let (top_env, req) = oo_add_class tables in
-+  let table_init = ref None in
-+  let (top_env, req) = oo_add_class tables table_init in
-   let top = not req in
-   let cl_env, llets = build_class_lets cl in
-   let new_ids = if top then [] else Env.diff top_env cl_env in
-@@ -633,6 +654,7 @@
-         begin try
-           (* Doesn't seem to improve size for bytecode *)
-           (* if not !Clflags.native_code then raise Not_found; *)
-+          if !Clflags.debug then raise Not_found;
-           builtin_meths arr [self] env env2 (lfunction args body')
-         with Not_found ->
-           [lfunction (self :: args)
-@@ -665,15 +687,8 @@
-     build_object_init_0 cla [] cl copy_env subst_env top ids in
-   if not (Translcore.check_recursive_lambda ids obj_init) then
-     raise(Error(cl.cl_loc, Illegal_class_expr));
--  let inh_init' = List.rev inh_init in
--  let (inh_init', cl_init) =
--    build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
--  in
--  assert (inh_init' = []);
--  let table = Ident.create "table"
--  and class_init = Ident.create (Ident.name cl_id ^ "_init")
--  and env_init = Ident.create "env_init"
--  and obj_init = Ident.create "obj_init" in
-+  let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in
-+  let obj_init = Ident.create "obj_init" in
-   let pub_meths =
-     List.sort
-       (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
-@@ -685,42 +700,44 @@
-       let name' = List.assoc tag rev_map in
-       if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
-     tags pub_meths;
-+  let pos = cl.cl_loc.Location.loc_end in
-+  let filepos = [transl_label pos.Lexing.pos_fname;
-+                 Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in
-   let ltable table lam =
--    Llet(Strict, table,
--         Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
-+    Llet(Strict, table, lprim "create_table" [transl_meth_list pub_meths], lam)
-   and ldirect obj_init =
-     Llet(Strict, obj_init, cl_init,
--         Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
-+         Lsequence(lprim "init_class_shared" (Lvar cla :: filepos),
-                    Lapply(Lvar obj_init, [lambda_unit])))
-   in
-   (* Simplest case: an object defined at toplevel (ids=[]) *)
-   if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
- 
-+  let table = Ident.create "table"
-+  and class_init = Ident.create (Ident.name cl_id ^ "_init")
-+  and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in
-+  let cl_init_fun = Lfunction(Curried, [cla], cl_init) in
-   let concrete =
-     ids = [] ||
-     Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
--  and lclass lam =
--    let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
-+  and lclass cl_init lam =
-     Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
-   and lbody fv =
-     if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
--      Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
--                                  Lvar class_init])
-+      lprim "make_class"
-+        (transl_meth_list pub_meths :: Lvar class_init :: filepos)
-     else
-       ltable table (
-       Llet(
-       Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
--      Lsequence(
--      Lapply (oo_prim "init_class", [Lvar table]),
--      Lprim(Pmakeblock(0, Immutable),
--          [Lapply(Lvar env_init, [lambda_unit]);
--           Lvar class_init; Lvar env_init; lambda_unit]))))
-+      Lsequence(lprim "init_class_shared" (Lvar table :: filepos),
-+                ltuple [Lapply(Lvar env_init, [lambda_unit]);
-+                      Lvar class_init; Lvar env_init; lambda_unit])))
-   and lbody_virt lenvs =
--    Lprim(Pmakeblock(0, Immutable),
--          [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
-+    ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs]
-   in
-   (* Still easy: a class defined at toplevel *)
--  if top && concrete then lclass lbody else
-+  if top && concrete then lclass (llets cl_init_fun) lbody else
-   if top then llets (lbody_virt lambda_unit) else
- 
-   (* Now for the hard stuff: prepare for table cacheing *)
-@@ -733,23 +750,16 @@
-   let lenv =
-     let menv =
-       if !new_ids_meths = [] then lambda_unit else
--      Lprim(Pmakeblock(0, Immutable),
--            List.map (fun id -> Lvar id) !new_ids_meths) in
-+      ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in
-     if !new_ids_init = [] then menv else
--    Lprim(Pmakeblock(0, Immutable),
--          menv :: List.map (fun id -> Lvar id) !new_ids_init)
-+    ltuple (menv :: List.map (fun id -> Lvar id) !new_ids_init)
-   and linh_envs =
-     List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
-       (List.rev inh_init)
-   in
-   let make_envs lam =
-     Llet(StrictOpt, envs,
--         (if linh_envs = [] then lenv else
--         Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)),
--         lam)
--  and def_ids cla lam =
--    Llet(StrictOpt, env2,
--         Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
-+         (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)),
-          lam)
-   in
-   let inh_paths =
-@@ -757,46 +767,53 @@
-       (fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
-   let inh_keys =
-     List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
--  let lclass lam =
--    Llet(Strict, class_init,
--         Lfunction(Curried, [cla], def_ids cla cl_init), lam)
-+  let lclass_init lam =
-+    Llet(Strict, class_init, cl_init_fun, lam)
-   and lcache lam =
-     if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
--    Llet(Strict, cached,
--         Lapply(oo_prim "lookup_tables",
--                [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
-+    Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple inh_keys],
-          lam)
-   and lset cached i lam =
-     Lprim(Psetfield(i, true), [Lvar cached; lam])
-   in
--  let ldirect () =
--    ltable cla
--      (Llet(Strict, env_init, def_ids cla cl_init,
--            Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
--                      lset cached 0 (Lvar env_init))))
--  and lclass_virt () =
--    lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
-+  let ldirect prim pos =
-+    ltable cla (
-+    Llet(Strict, env_init, cl_init,
-+         Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init)))
-+  and lclass_concrete cached =
-+    ltuple [Lapply (lfield cached 0, [lenvs]);
-+            lfield cached 1; lfield cached 0; lenvs]
-   in
-+
-   llets (
--  lcache (
--  Lsequence(
--  Lifthenelse(lfield cached 0, lambda_unit,
--              if ids = [] then ldirect () else
--              if not concrete then lclass_virt () else
--              lclass (
--              Lapply (oo_prim "make_class_store",
--                      [transl_meth_list pub_meths;
--                       Lvar class_init; Lvar cached]))),
-   make_envs (
--  if ids = [] then Lapply(lfield cached 0, [lenvs]) else
--  Lprim(Pmakeblock(0, Immutable),
--        if concrete then
--          [Lapply(lfield cached 0, [lenvs]);
--           lfield cached 1;
--           lfield cached 0;
--           lenvs]
--        else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
--       )))))
-+  if inh_paths = [] && concrete then
-+    if ids = [] then begin
-+      table_init := Some (ldirect "init_class_shared" filepos);
-+      Lapply (Lvar tables, [lenvs])
-+    end else begin
-+      let init =
-+        lclass cl_init_fun (fun _ ->
-+          lprim "make_class_env"
-+            (transl_meth_list pub_meths :: Lvar class_init :: filepos))
-+      in table_init := Some init;
-+      lclass_concrete tables
-+    end
-+  else begin
-+    lcache (
-+    Lsequence(
-+    Lifthenelse(lfield cached 0, lambda_unit,
-+                if ids = [] then lset cached 0 (ldirect "init_class" []) else
-+                if not concrete then lset cached 0 cl_init_fun else
-+                lclass_init (
-+                lprim "make_class_store"
-+                  [transl_meth_list pub_meths; Lvar class_init; Lvar cached])),
-+    llets (
-+    make_envs (
-+    if ids = [] then Lapply(lfield cached 0, [lenvs]) else
-+    if concrete then lclass_concrete cached else
-+    ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs]))))
-+  end))
- 
- (* Wrapper for class compilation *)
- 
-Index: bytecomp/translobj.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v
-retrieving revision 1.9
-diff -u -r1.9 translobj.ml
---- bytecomp/translobj.ml      26 May 2004 11:10:51 -0000      1.9
-+++ bytecomp/translobj.ml      2 Feb 2006 05:08:56 -0000
-@@ -88,7 +88,6 @@
- 
- (* Insert labels *)
- 
--let string s = Lconst (Const_base (Const_string s))
- let int n = Lconst (Const_base (Const_int n))
- 
- let prim_makearray =
-@@ -124,8 +123,8 @@
- let top_env = ref Env.empty
- let classes = ref []
- 
--let oo_add_class id =
--  classes := id :: !classes;
-+let oo_add_class id init =
-+  classes := (id, init) :: !classes;
-   (!top_env, !cache_required)
- 
- let oo_wrap env req f x =
-@@ -141,10 +140,12 @@
-     let lambda = f x in
-     let lambda =
-       List.fold_left
--        (fun lambda id ->
-+        (fun lambda (id, init) ->
-           Llet(StrictOpt, id,
--               Lprim(Pmakeblock(0, Mutable),
--                     [lambda_unit; lambda_unit; lambda_unit]),
-+               (match !init with
-+                 Some lam -> lam
-+               | None -> Lprim(Pmakeblock(0, Mutable),
-+                               [lambda_unit; lambda_unit; lambda_unit])),
-                lambda))
-         lambda !classes
-     in
-Index: bytecomp/translobj.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v
-retrieving revision 1.6
-diff -u -r1.6 translobj.mli
---- bytecomp/translobj.mli     26 May 2004 11:10:51 -0000      1.6
-+++ bytecomp/translobj.mli     2 Feb 2006 05:08:56 -0000
-@@ -25,4 +25,4 @@
-     Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
- 
- val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
--val oo_add_class: Ident.t -> Env.t * bool
-+val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool
-Index: byterun/compare.h
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v
-retrieving revision 1.2
-diff -u -r1.2 compare.h
---- byterun/compare.h  31 Dec 2003 14:20:35 -0000      1.2
-+++ byterun/compare.h  2 Feb 2006 05:08:56 -0000
-@@ -17,5 +17,6 @@
- #define CAML_COMPARE_H
- 
- CAMLextern int caml_compare_unordered;
-+CAMLextern value caml_compare(value, value);
- 
- #endif /* CAML_COMPARE_H */
-Index: byterun/extern.c
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v
-retrieving revision 1.59
-diff -u -r1.59 extern.c
---- byterun/extern.c   4 Jan 2006 16:55:49 -0000       1.59
-+++ byterun/extern.c   2 Feb 2006 05:08:56 -0000
-@@ -411,6 +411,22 @@
-       extern_record_location(v);
-       break;
-     }
-+    case Object_tag: {
-+      value field0;
-+      mlsize_t i;
-+      i = Wosize_val(Field(v, 0)) - 1;
-+      field0 = Field(Field(v, 0),i);
-+      if (Wosize_val(field0) > 0) {
-+        writecode32(CODE_OBJECT, Wosize_hd (hd));
-+        extern_record_location(v);
-+        extern_rec(field0);
-+        for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
-+        v = Field(v, i);
-+        goto tailcall;
-+      }
-+      if (!extern_closures)
-+        extern_invalid_argument("output_value: dynamic class");
-+    } /* may fall through */
-     default: {
-       value field0;
-       mlsize_t i;
-Index: byterun/intern.c
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v
-retrieving revision 1.60
-diff -u -r1.60 intern.c
---- byterun/intern.c   22 Sep 2005 14:21:50 -0000      1.60
-+++ byterun/intern.c   2 Feb 2006 05:08:56 -0000
-@@ -28,6 +28,8 @@
- #include "mlvalues.h"
- #include "misc.h"
- #include "reverse.h"
-+#include "callback.h"
-+#include "compare.h"
- 
- static unsigned char * intern_src;
- /* Reading pointer in block holding input data. */
-@@ -98,6 +100,25 @@
- #define readblock(dest,len) \
-   (memmove((dest), intern_src, (len)), intern_src += (len))
- 
-+static value get_method_table (value key)
-+{
-+  static value *classes = NULL;
-+  value current;
-+  if (classes == NULL) {
-+    classes = caml_named_value("caml_oo_classes");
-+    if (classes == NULL) return 0;
-+    caml_register_global_root(classes);
-+  }
-+  for (current = Field(*classes, 0); Is_block(current);
-+       current = Field(current, 1))
-+  {
-+    value head = Field(current, 0);
-+    if (caml_compare(key, Field(head, 0)) == Val_int(0))
-+      return Field(head, 1);
-+  }
-+  return 0;
-+}
-+
- static void intern_cleanup(void)
- {
-   if (intern_input_malloced) caml_stat_free(intern_input);
-@@ -315,6 +336,24 @@
-         Custom_ops_val(v) = ops;
-         intern_dest += 1 + size;
-         break;
-+      case CODE_OBJECT:
-+        size = read32u();
-+        v = Val_hp(intern_dest);
-+        *dest = v;
-+        if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
-+        dest = (value *) (intern_dest + 1);
-+        *intern_dest = Make_header(size, Object_tag, intern_color);
-+        intern_dest += 1 + size;
-+        intern_rec(dest);
-+        *dest = get_method_table(*dest);
-+        if (*dest == 0) {
-+          intern_cleanup();
-+          caml_failwith("input_value: unknown class");
-+        }
-+        for(size--, dest++; size > 1; size--, dest++)
-+          intern_rec(dest);
-+        goto tailcall;
-+        
-       default:
-         intern_cleanup();
-         caml_failwith("input_value: ill-formed message");
-Index: byterun/intext.h
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v
-retrieving revision 1.32
-diff -u -r1.32 intext.h
---- byterun/intext.h   22 Sep 2005 14:21:50 -0000      1.32
-+++ byterun/intext.h   2 Feb 2006 05:08:56 -0000
-@@ -56,6 +56,7 @@
- #define CODE_CODEPOINTER 0x10
- #define CODE_INFIXPOINTER 0x11
- #define CODE_CUSTOM 0x12
-+#define CODE_OBJECT 0x14
- 
- #if ARCH_FLOAT_ENDIANNESS == 0x76543210
- #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG
-Index: stdlib/camlinternalOO.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
-retrieving revision 1.14
-diff -u -r1.14 camlinternalOO.ml
---- stdlib/camlinternalOO.ml   25 Oct 2005 18:34:07 -0000      1.14
-+++ stdlib/camlinternalOO.ml   2 Feb 2006 05:08:56 -0000
-@@ -305,10 +305,38 @@
-     public_methods;
-   table
- 
-+(*
-+let create_table_variables pub_meths priv_meths vars =
-+  let tbl = create_table pub_meths in
-+  let pub_meths = to_array pub_meths
-+  and priv_meths = to_array priv_meths
-+  and vars = to_array vars in
-+  let len = 2 + Array.length pub_meths + Array.length priv_meths in
-+  let res = Array.create len tbl in
-+  let mv = new_methods_variables tbl pub_meths vars in
-+  Array.blit mv 0 res 1;
-+  res
-+*)
-+
- let init_class table =
-   inst_var_count := !inst_var_count + table.size - 1;
-   table.initializers <- List.rev table.initializers;
--  resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
-+  let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in
-+  (* keep 1 more for extra info *)
-+  let len = if len > Array.length table.methods then len else len+1 in
-+  resize table len
-+
-+let classes = ref []
-+let () = Callback.register "caml_oo_classes" classes
-+
-+let init_class_shared table (file : string) (pos : int) =
-+  init_class table;
-+  let rec unique_pos pos =
-+    if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000)
-+    else pos in
-+  let pos = unique_pos pos in
-+  table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos);
-+  classes := ((file, pos), table.methods) :: !classes
- 
- let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
-   narrow cla vals virt_meths concr_meths;
-@@ -319,12 +347,18 @@
-    Array.map (fun nm -> get_method cla (get_method_label cla nm))
-      (to_array concr_meths))
- 
--let make_class pub_meths class_init =
-+let make_class pub_meths class_init file pos =
-   let table = create_table pub_meths in
-   let env_init = class_init table in
--  init_class table;
-+  init_class_shared table file pos;
-   (env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
- 
-+let make_class_env pub_meths class_init file pos =
-+  let table = create_table pub_meths in
-+  let env_init = class_init table in
-+  init_class_shared table file pos;
-+  (env_init, class_init)
-+
- type init_table = { mutable env_init: t; mutable class_init: table -> t }
- 
- let make_class_store pub_meths class_init init_table =
-Index: stdlib/camlinternalOO.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
-retrieving revision 1.9
-diff -u -r1.9 camlinternalOO.mli
---- stdlib/camlinternalOO.mli  25 Oct 2005 18:34:07 -0000      1.9
-+++ stdlib/camlinternalOO.mli  2 Feb 2006 05:08:56 -0000
-@@ -43,14 +43,20 @@
- val add_initializer : table -> (obj -> unit) -> unit
- val dummy_table : table
- val create_table : string array -> table
-+(* val create_table_variables :
-+    string array -> string array -> string array -> table *)
- val init_class : table -> unit
-+val init_class_shared : table -> string -> int -> unit
- val inherits :
-     table -> string array -> string array -> string array ->
-     (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
-     (Obj.t * int array * closure array)
- val make_class :
--    string array -> (table -> Obj.t -> t) ->
-+    string array -> (table -> Obj.t -> t) -> string -> int ->
-     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
-+val make_class_env :
-+    string array -> (table -> Obj.t -> t) -> string -> int ->
-+    (Obj.t -> t) * (table -> Obj.t -> t)
- type init_table
- val make_class_store :
-     string array -> (table -> t) -> init_table -> unit

diff --git a/testlabl/multimatch.diffs b/testlabl/multimatch.diffs
deleted file mode 100644 (file)
index 6eb34b7..0000000
--- a/testlabl/multimatch.diffs
+++ /dev/null
@@ -1,1418 +0,0 @@
-Index: parsing/lexer.mll
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/lexer.mll,v
-retrieving revision 1.73
-diff -u -r1.73 lexer.mll
---- parsing/lexer.mll  11 Apr 2005 16:44:26 -0000      1.73
-+++ parsing/lexer.mll  2 Feb 2006 06:28:32 -0000
-@@ -63,6 +63,8 @@
-     "match", MATCH;
-     "method", METHOD;
-     "module", MODULE;
-+    "multifun", MULTIFUN;
-+    "multimatch", MULTIMATCH;
-     "mutable", MUTABLE;
-     "new", NEW;
-     "object", OBJECT;
-Index: parsing/parser.mly
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
-retrieving revision 1.123
-diff -u -r1.123 parser.mly
---- parsing/parser.mly 23 Mar 2005 03:08:37 -0000      1.123
-+++ parsing/parser.mly 2 Feb 2006 06:28:32 -0000
-@@ -257,6 +257,8 @@
- %token MINUSDOT
- %token MINUSGREATER
- %token MODULE
-+%token MULTIFUN
-+%token MULTIMATCH
- %token MUTABLE
- %token <nativeint> NATIVEINT
- %token NEW
-@@ -325,7 +327,7 @@
- %nonassoc SEMI                          /* below EQUAL ({lbl=...; lbl=...}) */
- %nonassoc LET                           /* above SEMI ( ...; let ... in ...) */
- %nonassoc below_WITH
--%nonassoc FUNCTION WITH                 /* below BAR  (match ... with ...) */
-+%nonassoc FUNCTION WITH MULTIFUN        /* below BAR  (match ... with ...) */
- %nonassoc AND             /* above WITH (module rec A: SIG with ... and ...) */
- %nonassoc THEN                          /* below ELSE (if ... then ...) */
- %nonassoc ELSE                          /* (if ... then ... else ...) */
-@@ -804,8 +806,12 @@
-       { mkexp(Pexp_function("", None, List.rev $3)) }
-   | FUN labeled_simple_pattern fun_def
-       { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
-+  | MULTIFUN opt_bar match_cases
-+      { mkexp(Pexp_multifun(List.rev $3)) }
-   | MATCH seq_expr WITH opt_bar match_cases
--      { mkexp(Pexp_match($2, List.rev $5)) }
-+      { mkexp(Pexp_match($2, List.rev $5, false)) }
-+  | MULTIMATCH seq_expr WITH opt_bar match_cases
-+      { mkexp(Pexp_match($2, List.rev $5, true)) }
-   | TRY seq_expr WITH opt_bar match_cases
-       { mkexp(Pexp_try($2, List.rev $5)) }
-   | TRY seq_expr WITH error
-@@ -1318,10 +1324,10 @@
-   | simple_core_type2                           { Rinherit $1 }
- ;
- tag_field:
--    name_tag OF opt_ampersand amper_type_list
--      { Rtag ($1, $3, List.rev $4) }
--  | name_tag
--      { Rtag ($1, true, []) }
-+    name_tag OF opt_ampersand amper_type_list amper_type_pair_list
-+      { Rtag ($1, $3, List.rev $4, $5) }
-+  | name_tag amper_type_pair_list
-+      { Rtag ($1, true, [], $2) }
- ;
- opt_ampersand:
-     AMPERSAND                                   { true }
-@@ -1331,6 +1337,11 @@
-     core_type                                   { [$1] }
-   | amper_type_list AMPERSAND core_type         { $3 :: $1 }
- ;
-+amper_type_pair_list:
-+    AMPERSAND core_type EQUAL core_type amper_type_pair_list
-+      { ($2, $4) :: $5 }
-+  | /* empty */
-+      { [] }
- opt_present:
-     LBRACKETGREATER name_tag_list RBRACKET      { List.rev $2 }
-   | /* empty */                                 { [] }
-Index: parsing/parsetree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
-retrieving revision 1.42
-diff -u -r1.42 parsetree.mli
---- parsing/parsetree.mli      23 Mar 2005 03:08:37 -0000      1.42
-+++ parsing/parsetree.mli      2 Feb 2006 06:28:32 -0000
-@@ -43,7 +43,7 @@
-   | Pfield_var
- 
- and row_field =
--    Rtag of label * bool * core_type list
-+    Rtag of label * bool * core_type list * (core_type * core_type) list
-   | Rinherit of core_type
- 
- (* XXX Type expressions for the class language *)
-@@ -86,7 +86,7 @@
-   | Pexp_let of rec_flag * (pattern * expression) list * expression
-   | Pexp_function of label * expression option * (pattern * expression) list
-   | Pexp_apply of expression * (label * expression) list
--  | Pexp_match of expression * (pattern * expression) list
-+  | Pexp_match of expression * (pattern * expression) list * bool
-   | Pexp_try of expression * (pattern * expression) list
-   | Pexp_tuple of expression list
-   | Pexp_construct of Longident.t * expression option * bool
-@@ -111,6 +111,7 @@
-   | Pexp_lazy of expression
-   | Pexp_poly of expression * core_type option
-   | Pexp_object of class_structure
-+  | Pexp_multifun of (pattern * expression) list
- 
- (* Value descriptions *)
- 
-Index: parsing/printast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
-retrieving revision 1.29
-diff -u -r1.29 printast.ml
---- parsing/printast.ml        4 Jan 2006 16:55:50 -0000       1.29
-+++ parsing/printast.ml        2 Feb 2006 06:28:32 -0000
-@@ -205,10 +205,14 @@
-       line i ppf "Pexp_apply\n";
-       expression i ppf e;
-       list i label_x_expression ppf l;
--  | Pexp_match (e, l) ->
-+  | Pexp_match (e, l, b) ->
-       line i ppf "Pexp_match\n";
-       expression i ppf e;
-       list i pattern_x_expression_case ppf l;
-+      bool i ppf b
-+  | Pexp_multifun l ->
-+      line i ppf "Pexp_multifun\n";
-+      list i pattern_x_expression_case ppf l;
-   | Pexp_try (e, l) ->
-       line i ppf "Pexp_try\n";
-       expression i ppf e;
-@@ -653,7 +657,7 @@
- 
- and label_x_bool_x_core_type_list i ppf x =
-   match x with
--    Rtag (l, b, ctl) ->
-+    Rtag (l, b, ctl, cstr) ->
-       line i ppf "Rtag \"%s\" %s\n" l (string_of_bool b);
-       list (i+1) core_type ppf ctl
-   | Rinherit (ct) ->
-Index: typing/btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.38
-diff -u -r1.38 btype.ml
---- typing/btype.ml    4 Jan 2006 16:55:50 -0000       1.38
-+++ typing/btype.ml    2 Feb 2006 06:28:32 -0000
-@@ -66,16 +66,16 @@
-     Clink r when !r <> Cunknown -> commu_repr !r
-   | c -> c
- 
--let rec row_field_repr_aux tl = function
--    Reither(_, tl', _, {contents = Some fi}) ->
--      row_field_repr_aux (tl@tl') fi
--  | Reither(c, tl', m, r) ->
--      Reither(c, tl@tl', m, r)
-+let rec row_field_repr_aux tl tl2 = function
-+    Reither(_, tl', _, tl2', {contents = Some fi}) ->
-+      row_field_repr_aux (tl@tl') (tl2@tl2') fi
-+  | Reither(c, tl', m, tl2', r) ->
-+      Reither(c, tl@tl', m, tl2@tl2', r)
-   | Rpresent (Some _) when tl <> [] ->
-       Rpresent (Some (List.hd tl))
-   | fi -> fi
- 
--let row_field_repr fi = row_field_repr_aux [] fi
-+let row_field_repr fi = row_field_repr_aux [] [] fi
- 
- let rec rev_concat l ll =
-   match ll with
-@@ -170,7 +170,8 @@
-     (fun (_, fi) ->
-       match row_field_repr fi with
-       | Rpresent(Some ty) -> f ty
--      | Reither(_, tl, _, _) -> List.iter f tl
-+      | Reither(_, tl, _, tl2, _) ->
-+          List.iter f tl; List.iter (fun (t1,t2) -> f t1; f t2) tl2
-       | _ -> ())
-     row.row_fields;
-   match (repr row.row_more).desc with
-@@ -208,15 +209,17 @@
-       (fun (l, fi) -> l,
-         match row_field_repr fi with
-         | Rpresent(Some ty) -> Rpresent(Some(f ty))
--        | Reither(c, tl, m, e) ->
-+        | Reither(c, tl, m, tpl, e) ->
-             let e = if keep then e else ref None in
-             let m = if row.row_fixed then fixed else m in
-             let tl = List.map f tl in
-+            let tl1 = List.map (fun (t1,_) -> repr (f t1)) tpl
-+            and tl2 = List.map (fun (_,t2) -> repr (f t2)) tpl in
-             bound := List.filter
-                 (function {desc=Tconstr(_,[],_)} -> false | _ -> true)
--                (List.map repr tl)
-+                (List.map repr tl @ tl1 @ tl2)
-               @ !bound;
--            Reither(c, tl, m, e)
-+            Reither(c, tl, m, List.combine tl1 tl2, e)
-         | _ -> fi)
-       row.row_fields in
-   let name =
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.200
-diff -u -r1.200 ctype.ml
---- typing/ctype.ml    6 Jan 2006 02:16:24 -0000       1.200
-+++ typing/ctype.ml    2 Feb 2006 06:28:32 -0000
-@@ -340,7 +340,7 @@
-       let fi = filter_row_fields erase fi in
-       match row_field_repr f with
-         Rabsent -> fi
--      | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi
-+      | Reither(_,_,false,_,e) when erase -> set_row_field e Rabsent; fi
-       | _ -> p :: fi
- 
-                     (**************************************)
-@@ -1286,6 +1286,10 @@
- 
- module TypeMap = Map.Make (TypeOps)
- 
-+
-+(* A list of univars which may appear free in a type, but only if generic *)
-+let allowed_univars = ref TypeSet.empty
-+
- (* Test the occurence of free univars in a type *)
- (* that's way too expansive. Must do some kind of cacheing *)
- let occur_univar env ty =
-@@ -1307,7 +1311,12 @@
-     then
-       match ty.desc with
-         Tunivar ->
--          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
-+          if TypeSet.mem ty bound then () else
-+          if TypeSet.mem ty !allowed_univars &&
-+            (ty.level = generic_level ||
-+             ty.level = pivot_level - generic_level)
-+          then ()
-+          else raise (Unify [ty, newgenvar()])
-       | Tpoly (ty, tyl) ->
-           let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
-           occur_rec bound  ty
-@@ -1393,6 +1402,7 @@
-   with exn -> univar_pairs := old_univars; raise exn
- 
- let univar_pairs = ref []
-+let delayed_conditionals = ref []
- 
- 
-                               (*****************)
-@@ -1691,9 +1701,11 @@
-               with Not_found -> (h,l)::hl)
-             (List.map (fun (l,_) -> (hash_variant l, l)) row1.row_fields)
-             (List.map fst r2));
-+  let fixed1 = row1.row_fixed || rm1.desc <> Tvar
-+  and fixed2 = row2.row_fixed || rm2.desc <> Tvar in
-   let more =
--    if row1.row_fixed then rm1 else
--    if row2.row_fixed then rm2 else
-+    if fixed1 then rm1 else
-+    if fixed2 then rm2 else
-     newgenvar ()
-   in update_level env (min rm1.level rm2.level) more;
-   let fixed = row1.row_fixed || row2.row_fixed
-@@ -1726,18 +1738,18 @@
-   let bound = row1.row_bound @ row2.row_bound in
-   let row0 = {row_fields = []; row_more = more; row_bound = bound;
-               row_closed = closed; row_fixed = fixed; row_name = name} in
--  let set_more row rest =
-+  let set_more row row_fixed rest =
-     let rest =
-       if closed then
-         filter_row_fields row.row_closed rest
-       else rest in
--    if rest <> [] && (row.row_closed || row.row_fixed)
--    || closed && row.row_fixed && not row.row_closed then begin
-+    if rest <> [] && (row.row_closed || row_fixed)
-+    || closed && row_fixed && not row.row_closed then begin
-       let t1 = mkvariant [] true and t2 = mkvariant rest false in
-       raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
-     end;
-     let rm = row_more row in
--    if row.row_fixed then
-+    if row_fixed then
-       if row0.row_more == rm then () else
-       if rm.desc = Tvar then link_type rm row0.row_more else
-       unify env rm row0.row_more
-@@ -1748,11 +1760,11 @@
-   in
-   let md1 = rm1.desc and md2 = rm2.desc in
-   begin try
--    set_more row1 r2;
--    set_more row2 r1;
-+    set_more row1 fixed1 r2;
-+    set_more row2 fixed2 r1;
-     List.iter
-       (fun (l,f1,f2) ->
--        try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2
-+        try unify_row_field env fixed1 fixed2 row1 row2 l f1 f2
-         with Unify trace ->
-           raise (Unify ((mkvariant [l,f1] true,
-                          mkvariant [l,f2] true) :: trace)))
-@@ -1761,13 +1773,13 @@
-     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
-   end
- 
--and unify_row_field env fixed1 fixed2 l f1 f2 =
-+and unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 =
-   let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
-   if f1 == f2 then () else
-   match f1, f2 with
-     Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
-   | Rpresent None, Rpresent None -> ()
--  | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
-+  | Reither(c1, tl1, m1, tp1, e1), Reither(c2, tl2, m2, tp2, e2) ->
-       if e1 == e2 then () else
-       let redo =
-         (m1 || m2) &&
-@@ -1777,32 +1789,70 @@
-             List.iter (unify env t1) tl;
-             !e1 <> None || !e2 <> None
-         end in
--      if redo then unify_row_field env fixed1 fixed2 l f1 f2 else
-+      let redo =
-+        redo || begin
-+          if tp1 = [] && fixed1 then unify_pairs env tp2;
-+          if tp2 = [] && fixed2 then unify_pairs env tp1;
-+          !e1 <> None || !e2 <> None
-+        end
-+      in
-+      if redo then unify_row_field env fixed1 fixed2 row1 row2 l f1 f2 else
-       let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
-       let rec remq tl = function [] -> []
-         | ty :: tl' ->
-             if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
-       in
-       let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
-+      let repr_pairs = List.map (fun (t1,t2) -> repr t1, repr t2) in
-+      let tp1 = repr_pairs tp1 and tp2 = repr_pairs tp2 in
-+      let rec rempq tp = function [] -> []
-+        | (t1,t2 as p) :: tp' ->
-+            if List.exists (fun (t1',t2') -> t1==t1' && t2==t2') (tp@tp') then
-+              rempq tp tp'
-+            else p :: rempq tp tp'
-+      in
-+      let tp1' =
-+        if fixed2 then begin
-+          delayed_conditionals :=
-+            (!univar_pairs, tp1, l, row2) :: !delayed_conditionals;
-+          []
-+        end else rempq tp2 tp1
-+      and tp2' =
-+        if fixed1 then begin
-+          delayed_conditionals :=
-+            (!univar_pairs, tp2, l, row1) :: !delayed_conditionals;
-+          []
-+        end else rempq tp1 tp2
-+      in
-       let e = ref None in
--      let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
--      and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
--      set_row_field e1 f1'; set_row_field e2 f2';
--  | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2
--  | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1
-+      let f1' = Reither(c1 || c2, tl1', m1 || m2, tp2', e)
-+      and f2' = Reither(c1 || c2, tl2', m1 || m2, tp1', e) in
-+      set_row_field e1 f1'; set_row_field e2 f2'
-+  | Reither(_, _, false, _, e1), Rabsent -> set_row_field e1 f2
-+  | Rabsent, Reither(_, _, false, _, e2) -> set_row_field e2 f1
-   | Rabsent, Rabsent -> ()
--  | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
-+  | Reither(false, tl, _, tp, e1), Rpresent(Some t2) when not fixed1 ->
-       set_row_field e1 f2;
--      (try List.iter (fun t1 -> unify env t1 t2) tl
-+      begin try
-+        List.iter (fun t1 -> unify env t1 t2) tl;
-+        List.iter (fun (t1,t2) -> unify env t1 t2) tp
-+      with exn -> e1 := None; raise exn
-+      end
-+  | Rpresent(Some t1), Reither(false, tl, _, tp, e2) when not fixed2 ->
-+      set_row_field e2 f1;
-+      begin try
-+        List.iter (unify env t1) tl;
-+        List.iter (fun (t1,t2) -> unify env t1 t2) tp
-+      with exn -> e2 := None; raise exn
-+      end
-+  | Reither(true, [], _, tpl, e1), Rpresent None when not fixed1 ->
-+      set_row_field e1 f2;
-+      (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
-       with exn -> e1 := None; raise exn)
--  | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
-+  | Rpresent None, Reither(true, [], _, tpl, e2) when not fixed2 ->
-       set_row_field e2 f1;
--      (try List.iter (unify env t1) tl
-+      (try List.iter (fun (t1,t2) -> unify env t1 t2) tpl
-       with exn -> e2 := None; raise exn)
--  | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
--      set_row_field e1 f2
--  | Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
--      set_row_field e2 f1
-   | _ -> raise (Unify [])
-     
- 
-@@ -1920,6 +1970,166 @@
-                         (*  Matching between type schemes  *)
-                         (***********************************)
- 
-+(* Forward declaration (order should be reversed...) *)
-+let equal' = ref (fun _ -> failwith "Ctype.equal'")
-+
-+let make_generics_univars tyl =
-+  let polyvars = ref TypeSet.empty in
-+  let rec make_rec ty =
-+    let ty = repr ty in
-+    if ty.level = generic_level then begin
-+      if ty.desc = Tvar  then begin
-+        log_type ty;
-+        ty.desc <- Tunivar;
-+        polyvars := TypeSet.add ty !polyvars
-+      end
-+      else if ty.desc = Tunivar then set_level ty (generic_level - 1);
-+      ty.level <- pivot_level - generic_level;
-+      iter_type_expr make_rec ty
-+    end
-+  in
-+  List.iter make_rec tyl;
-+  List.iter unmark_type tyl;
-+  !polyvars
-+
-+(* New version of moregeneral, using unification *)
-+
-+let copy_cond (p,tpl,l,row) =
-+  let row =
-+    match repr (copy (newgenty (Tvariant row))) with
-+      {desc=Tvariant row} -> row
-+    | _ -> assert false
-+  and pairs =
-+    List.map (fun (t1,t2) -> copy t1, copy t2) tpl in
-+  (p, pairs, l, row)
-+
-+let get_row_field l row =
-+  try row_field_repr (List.assoc l (row_repr row).row_fields)
-+  with Not_found -> Rabsent
-+
-+let rec check_conditional_list env cdtls pattvars tpls =
-+  match cdtls with
-+    [] ->
-+      let finished =
-+        List.for_all (fun (_,t1,t2) -> !equal' env false [t1] [t2]) tpls in
-+      if not finished then begin
-+        let polyvars = make_generics_univars pattvars in
-+        delayed_conditionals := [];
-+        allowed_univars := polyvars;
-+        List.iter (fun (pairs, ty1, ty2) -> unify_pairs env ty1 ty2 pairs)
-+          tpls;
-+        check_conditionals env polyvars !delayed_conditionals
-+      end
-+  | (pairs, tpl1, l, row2 as cond) :: cdtls ->
-+      let cont = check_conditional_list env cdtls pattvars in
-+      let tpl1 =
-+        List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
-+      let included =
-+        List.for_all
-+          (fun (t1,t2) ->
-+            List.exists
-+              (fun (_,t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
-+              tpls)
-+          tpl1 in
-+      if included then cont tpls else
-+      match get_row_field l row2 with
-+        Rpresent _ ->
-+          cont (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
-+      | Rabsent -> cont tpls
-+      | Reither (c, tl2, _, _, _) ->
-+          cont tpls;
-+          if c && tl2 <> [] then () (* cannot succeed *) else
-+          let (pairs, tpl1, l, row2) = copy_cond cond
-+          and tpls = List.map (fun (p,t1,t2) -> p, copy t1, copy t2) tpls
-+          and pattvars = List.map copy pattvars
-+          and cdtls = List.map copy_cond cdtls in
-+          cleanup_types ();
-+          let tl2, tpl2, e2 =
-+            match get_row_field l row2 with
-+              Reither (c, tl2, _, tpl2, e2) -> tl2, tpl2, e2
-+            | _ -> assert false
-+          in
-+          let snap = Btype.snapshot () in
-+          let ok =
-+            try
-+              begin match tl2 with
-+                [] ->
-+                  set_row_field e2 (Rpresent None)
-+              | t::tl ->
-+                  set_row_field e2 (Rpresent (Some t));
-+                  List.iter (unify env t) tl
-+              end;
-+              List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
-+              true
-+            with exn ->
-+              Btype.backtrack snap;
-+              false
-+          in
-+            (* This is not [cont] : types have been copied *)
-+          if ok then
-+            check_conditional_list env cdtls pattvars
-+              (List.map (fun (t1,t2) -> (pairs,t1,t2)) tpl1 @ tpls)
-+
-+and check_conditionals env polyvars cdtls =
-+  let cdtls = List.map copy_cond cdtls in
-+  let pattvars = ref [] in
-+  TypeSet.iter
-+    (fun ty ->
-+      let ty = repr ty in
-+      match ty.desc with
-+        Tsubst ty ->
-+          let ty = repr ty in
-+          begin match ty.desc with
-+            Tunivar ->
-+              log_type ty;
-+              ty.desc <- Tvar;
-+              pattvars := ty :: !pattvars
-+          | Ttuple [tv;_] ->
-+              if tv.desc = Tunivar then
-+                (log_type tv; tv.desc <- Tvar; pattvars := ty :: !pattvars)
-+              else if tv.desc <> Tvar then assert false
-+          | Tvar -> ()
-+          | _ -> assert false
-+          end
-+      | _ -> ())
-+    polyvars;
-+  cleanup_types ();
-+  check_conditional_list env cdtls !pattvars []
-+  
-+
-+(* Must empty univar_pairs first *)
-+let unify_poly env polyvars subj patt =
-+  let old_level = !current_level in
-+  current_level := generic_level;
-+  delayed_conditionals := [];
-+  allowed_univars := polyvars;
-+  try
-+    unify env subj patt;
-+    check_conditionals env polyvars !delayed_conditionals;
-+    current_level := old_level;
-+    allowed_univars := TypeSet.empty;
-+    delayed_conditionals := []
-+  with exn ->
-+    current_level := old_level;
-+    allowed_univars := TypeSet.empty;
-+    delayed_conditionals := [];
-+    raise exn
-+
-+let moregeneral env _ subj patt =
-+  let old_level = !current_level in
-+  current_level := generic_level;
-+  let subj = instance subj
-+  and patt = instance patt in
-+  let polyvars = make_generics_univars [patt] in
-+  current_level := old_level;
-+  let snap = Btype.snapshot () in
-+  try
-+    unify_poly env polyvars subj patt;
-+    true
-+  with Unify _ ->
-+    Btype.backtrack snap;
-+    false
-+
- (*
-    Update the level of [ty]. First check that the levels of generic
-    variables from the subject are not lowered.
-@@ -2072,35 +2282,101 @@
-         Rpresent(Some t1), Rpresent(Some t2) ->
-           moregen inst_nongen type_pairs env t1 t2
-       | Rpresent None, Rpresent None -> ()
--      | Reither(false, tl1, _, e1), Rpresent(Some t2) when not univ ->
-+      | Reither(false, tl1, _, [], e1), Rpresent(Some t2) when not univ ->
-           set_row_field e1 f2;
-           List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1
--      | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) ->
-+      | Reither(c1, tl1, _, tpl1, e1), Reither(c2, tl2, m2, tpl2, e2) ->
-           if e1 != e2 then begin
-             if c1 && not c2 then raise(Unify []);
--            set_row_field e1 (Reither (c2, [], m2, e2));
--            if List.length tl1 = List.length tl2 then
--              List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
--            else match tl2 with
--              t2 :: _ ->
-+            let tpl' = if tpl1 = [] then tpl2 else [] in
-+            set_row_field e1 (Reither (c2, [], m2, tpl', e2));
-+            begin match tl2 with
-+              [t2] ->
-                 List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2)
-                   tl1
--            | [] ->
--                if tl1 <> [] then raise (Unify [])
-+            | _ ->
-+                if List.length tl1 <> List.length tl2 then raise (Unify []);
-+                List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2
-+            end;
-+            if tpl1 <> [] then
-+              delayed_conditionals :=
-+                (!univar_pairs, tpl1, l, row2) :: !delayed_conditionals
-           end
--      | Reither(true, [], _, e1), Rpresent None when not univ ->
-+      | Reither(true, [], _, [], e1), Rpresent None when not univ ->
-           set_row_field e1 f2
--      | Reither(_, _, _, e1), Rabsent when not univ ->
-+      | Reither(_, _, _, [], e1), Rabsent when not univ ->
-           set_row_field e1 f2
-       | Rabsent, Rabsent -> ()
-       | _ -> raise (Unify []))
-     pairs
- 
-+let check_conditional env (pairs, tpl1, l, row2) tpls cont =
-+  let tpl1 =
-+    List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpl1 in
-+  let included =
-+    List.for_all
-+      (fun (t1,t2) ->
-+        List.exists (fun (t1',t2') -> !equal' env false [t1;t2] [t1';t2'])
-+          tpls)
-+      tpl1 in
-+  if tpl1 = [] || included then cont tpls else
-+  match get_row_field l row2 with
-+    Rpresent _ -> cont (tpl1 @ tpls)
-+  | Rabsent -> cont tpls
-+  | Reither (c, tl2, _, tpl2, e2) ->
-+      if not c || tl2 = [] then begin
-+        let snap = Btype.snapshot () in
-+        let ok =
-+          try
-+            begin match tl2 with
-+              [] ->
-+                set_row_field e2 (Rpresent None)
-+            | t::tl ->
-+                set_row_field e2 (Rpresent (Some t));
-+                List.iter (unify env t) tl
-+            end;
-+            List.iter (fun (t1,t2) -> unify_pairs env t1 t2 pairs) tpl2;
-+            true
-+          with Unify _ -> false
-+        in
-+        if ok then cont (tpl1 @ tpls);
-+        Btype.backtrack snap
-+      end;
-+      cont tpls
-+
-+let rec check_conditionals inst_nongen env cdtls tpls =
-+  match cdtls with
-+    [] ->
-+      let tpls =
-+        List.filter (fun (t1,t2) -> not (!equal' env false [t1] [t2])) tpls in
-+      if tpls = [] then () else begin
-+        delayed_conditionals := [];
-+        let tl1, tl2 = List.split tpls in
-+        let type_pairs = TypePairs.create 13 in
-+        List.iter2 (moregen false type_pairs env) tl2 tl1;
-+        check_conditionals inst_nongen env !delayed_conditionals []
-+      end
-+  | cdtl :: cdtls ->
-+      check_conditional env cdtl tpls
-+        (check_conditionals inst_nongen env cdtls)
-+
-+
- (* Must empty univar_pairs first *)
- let moregen inst_nongen type_pairs env patt subj =
-   univar_pairs := [];
--  moregen inst_nongen type_pairs env patt subj
-+  delayed_conditionals := [];
-+  try
-+    moregen inst_nongen type_pairs env patt subj;
-+    check_conditionals inst_nongen env !delayed_conditionals [];
-+    univar_pairs := [];
-+    delayed_conditionals := []
-+  with exn ->
-+    univar_pairs := [];
-+    delayed_conditionals := [];
-+    raise exn
-+
- 
-+(* old implementation
- (*
-    Non-generic variable can be instanciated only if [inst_nongen] is
-    true. So, [inst_nongen] should be set to false if the subject might
-@@ -2128,6 +2404,7 @@
-   in
-   current_level := old_level;
-   res
-+*)
- 
- 
- (* Alternative approach: "rigidify" a type scheme,
-@@ -2296,30 +2573,36 @@
-     {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
-   | _ -> raise Cannot_expand
-   with Cannot_expand ->
-+  let eqtype_rec = eqtype rename type_pairs subst env in
-   let row1 = row_repr row1 and row2 = row_repr row2 in
-   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
-   if row1.row_closed <> row2.row_closed
-   || not row1.row_closed && (r1 <> [] || r2 <> [])
-   || filter_row_fields false (r1 @ r2) <> []
-   then raise (Unify []);
--  if not (static_row row1) then
--    eqtype rename type_pairs subst env row1.row_more row2.row_more;
-+  if not (static_row row1) then eqtype_rec row1.row_more row2.row_more;
-   List.iter
-     (fun (_,f1,f2) ->
-       match row_field_repr f1, row_field_repr f2 with
-         Rpresent(Some t1), Rpresent(Some t2) ->
--          eqtype rename type_pairs subst env t1 t2
--      | Reither(true, [], _, _), Reither(true, [], _, _) ->
--          ()
--      | Reither(false, t1::tl1, _, _), Reither(false, t2::tl2, _, _) ->
--          eqtype rename type_pairs subst env t1 t2;
-+          eqtype_rec t1 t2
-+      | Reither(true, [], _, tp1, _), Reither(true, [], _, tp2, _) ->
-+          List.iter2
-+            (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
-+            tp1 tp2
-+      | Reither(false, t1::tl1, _, tpl1, _),
-+        Reither(false, t2::tl2, _, tpl2, _) ->
-+          eqtype_rec t1 t2;
-+          List.iter2
-+            (fun (t1,t1') (t2,t2') -> eqtype_rec t1 t2; eqtype_rec t1' t2')
-+            tpl1 tpl2;
-           if List.length tl1 = List.length tl2 then
-             (* if same length allow different types (meaning?) *)
--            List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
-+            List.iter2 eqtype_rec tl1 tl2
-           else begin
-             (* otherwise everything must be equal *)
--            List.iter (eqtype rename type_pairs subst env t1) tl2;
--            List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1
-+            List.iter (eqtype_rec t1) tl2;
-+            List.iter (fun t1 -> eqtype_rec t1 t2) tl1
-           end
-       | Rpresent None, Rpresent None -> ()
-       | Rabsent, Rabsent -> ()
-@@ -2334,6 +2617,8 @@
-   with
-     Unify _ -> false
- 
-+let () = equal' := equal
-+
- (* Must empty univar_pairs first *)  
- let eqtype rename type_pairs subst env t1 t2 =
-   univar_pairs := [];
-@@ -2770,14 +3055,14 @@
-           (fun (l,f as orig) -> match row_field_repr f with
-             Rpresent None ->
-               if posi then
--                (l, Reither(true, [], false, ref None)), Unchanged
-+                (l, Reither(true, [], false, [], ref None)), Unchanged
-               else
-                 orig, Unchanged
-           | Rpresent(Some t) ->
-               let (t', c) = build_subtype env visited loops posi level' t in
-               if posi && level > 0 then begin
-                 bound := t' :: !bound;
--                (l, Reither(false, [t'], false, ref None)), c
-+                (l, Reither(false, [t'], false, [], ref None)), c
-               end else
-                 (l, Rpresent(Some t')), c
-           | _ -> assert false)
-@@ -2960,11 +3245,11 @@
-       List.fold_left
-         (fun cstrs (_,f1,f2) ->
-           match row_field_repr f1, row_field_repr f2 with
--            (Rpresent None|Reither(true,_,_,_)), Rpresent None ->
-+            (Rpresent None|Reither(true,_,_,[],_)), Rpresent None ->
-               cstrs
-           | Rpresent(Some t1), Rpresent(Some t2) ->
-               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
--          | Reither(false, t1::_, _, _), Rpresent(Some t2) ->
-+          | Reither(false, t1::_, _, [], _), Rpresent(Some t2) ->
-               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
-           | Rabsent, _ -> cstrs
-           | _ -> raise Exit)
-@@ -2977,11 +3262,11 @@
-         (fun cstrs (_,f1,f2) ->
-           match row_field_repr f1, row_field_repr f2 with
-             Rpresent None, Rpresent None
--          | Reither(true,[],_,_), Reither(true,[],_,_)
-+          | Reither(true,[],_,[],_), Reither(true,[],_,[],_)
-           | Rabsent, Rabsent ->
-               cstrs
-           | Rpresent(Some t1), Rpresent(Some t2)
--          | Reither(false,[t1],_,_), Reither(false,[t2],_,_) ->
-+          | Reither(false,[t1],_,[],_), Reither(false,[t2],_,[],_) ->
-               subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
-           | _ -> raise Exit)
-         cstrs pairs
-@@ -3079,16 +3364,26 @@
-       let fields = List.map
-           (fun (l,f) ->
-             let f = row_field_repr f in l,
--            match f with Reither(b, ty::(_::_ as tyl), m, e) ->
--              let tyl' =
--                List.fold_left
--                  (fun tyl ty ->
--                    if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
--                    then tyl else ty::tyl)
--                  [ty] tyl
-+            match f with Reither(b, tyl, m, tp, e) ->
-+              let rem_dbl eq l =
-+                List.rev
-+                  (List.fold_left
-+                     (fun xs x -> if List.exists (eq x) xs then xs else x::xs)
-+                     [] l)
-+              in
-+              let tyl' = rem_dbl (fun t1 t2 -> equal env false [t1] [t2]) tyl
-+              and tp' =
-+                  List.filter
-+                    (fun (ty1,ty2) -> not (equal env false [ty1] [ty2])) tp
-+              in
-+              let tp' =
-+                rem_dbl
-+                  (fun (t1,t2) (t1',t2') -> equal env false [t1;t2] [t1';t2'])
-+                  tp'
-               in
--              if List.length tyl' <= List.length tyl then
--                let f = Reither(b, List.rev tyl', m, ref None) in
-+              if List.length tyl' < List.length tyl
-+              || List.length tp' < List.length tp then
-+                let f = Reither(b, tyl', m, tp', ref None) in
-                 set_row_field e f;
-                 f
-               else f
-@@ -3344,9 +3639,9 @@
-       List.iter
-         (fun (l,fi) ->
-           match row_field_repr fi with
--            Reither (c, t1::(_::_ as tl), m, e) ->
-+            Reither (c, t1::(_::_ as tl), m, tp, e) ->
-               List.iter (unify env t1) tl;
--              set_row_field e (Reither (c, [t1], m, ref None))
-+              set_row_field e (Reither (c, [t1], m, tp, ref None))
-           | _ ->
-               ())
-         row.row_fields;
-Index: typing/includecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/includecore.ml,v
-retrieving revision 1.32
-diff -u -r1.32 includecore.ml
---- typing/includecore.ml      8 Aug 2005 05:40:52 -0000       1.32
-+++ typing/includecore.ml      2 Feb 2006 06:28:32 -0000
-@@ -71,10 +71,10 @@
-       (fun (_, f1, f2) ->
-         match Btype.row_field_repr f1, Btype.row_field_repr f2 with
-           Rpresent(Some t1),
--          (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
-+          (Rpresent(Some t2) | Reither(false,[t2],_,[],_)) ->
-             to_equal := (t1,t2) :: !to_equal; true
--        | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
--        | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
-+        | Rpresent None, (Rpresent None | Reither(true,[],_,[],_)) -> true
-+        | Reither(c1,tl1,_,[],_), Reither(c2,tl2,_,[],_)
-           when List.length tl1 = List.length tl2 && c1 = c2 ->
-             to_equal := List.combine tl1 tl2 @ !to_equal; true
-         | Rabsent, (Reither _ | Rabsent) -> true
-Index: typing/oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- typing/oprint.ml   23 Mar 2005 03:08:37 -0000      1.22
-+++ typing/oprint.ml   2 Feb 2006 06:28:33 -0000
-@@ -223,14 +223,18 @@
-       print_fields rest ppf []
-   | (s, t) :: l ->
-       fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l
--and print_row_field ppf (l, opt_amp, tyl) =
-+and print_row_field ppf (l, opt_amp, tyl, tpl) =
-   let pr_of ppf =
-     if opt_amp then fprintf ppf " of@ &@ "
-     else if tyl <> [] then fprintf ppf " of@ "
--    else fprintf ppf ""
--  in
--  fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &")
--    tyl
-+  and pr_tp ppf (t1,t2) =
-+    fprintf ppf "@[<hv 2>%a =@ %a@]"
-+      print_out_type t1
-+      print_out_type t2
-+  in
-+  fprintf ppf "@[<hv 2>`%s%t%a%a@]" l pr_of
-+    (print_typlist print_out_type " &") tyl
-+    (print_list_init pr_tp (fun ppf -> fprintf ppf " &@ ")) tpl
- and print_typlist print_elem sep ppf =
-   function
-     [] -> ()
-Index: typing/outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- typing/outcometree.mli     23 Mar 2005 03:08:37 -0000      1.14
-+++ typing/outcometree.mli     2 Feb 2006 06:28:33 -0000
-@@ -61,7 +61,8 @@
-       bool * out_variant * bool * (string list) option
-   | Otyp_poly of string list * out_type
- and out_variant =
--  | Ovar_fields of (string * bool * out_type list) list
-+  | Ovar_fields of
-+      (string * bool * out_type list * (out_type * out_type) list ) list
-   | Ovar_name of out_ident * out_type list
- 
- type out_class_type =
-Index: typing/parmatch.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/parmatch.ml,v
-retrieving revision 1.70
-diff -u -r1.70 parmatch.ml
---- typing/parmatch.ml 24 Mar 2005 17:20:54 -0000      1.70
-+++ typing/parmatch.ml 2 Feb 2006 06:28:33 -0000
-@@ -568,11 +568,11 @@
-     List.fold_left
-       (fun nm (tag,f) ->
-         match Btype.row_field_repr f with
--        | Reither(_, _, false, e) ->
-+        | Reither(_, _, false, _, e) ->
-             (* m=false means that this tag is not explicitly matched *)
-             Btype.set_row_field e Rabsent;
-             None
--        | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm)
-+        | Rabsent | Reither (_, _, true, _, _) | Rpresent _ -> nm)
-       row.row_name row.row_fields in
-   if not row.row_closed || nm != row.row_name then begin
-     (* this unification cannot fail *)
-@@ -605,8 +605,8 @@
-       List.for_all
-         (fun (tag,f) ->
-           match Btype.row_field_repr f with
--            Rabsent | Reither(_, _, false, _) -> true
--          | Reither (_, _, true, _)
-+            Rabsent | Reither(_, _, false, _, _) -> true
-+          | Reither (_, _, true, _, _)
-               (* m=true, do not discard matched tags, rather warn *)
-           | Rpresent _ -> List.mem tag fields)
-         row.row_fields
-@@ -739,7 +739,7 @@
-           match Btype.row_field_repr f with
-             Rabsent (* | Reither _ *) -> others
-           (* This one is called after erasing pattern info *)
--          | Reither (c, _, _, _) -> make_other_pat tag c :: others
-+          | Reither (c, _, _, _, _) -> make_other_pat tag c :: others
-           | Rpresent arg -> make_other_pat tag (arg = None) :: others)
-         [] row.row_fields
-     with
-Index: typing/printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.140
-diff -u -r1.140 printtyp.ml
---- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000       1.140
-+++ typing/printtyp.ml 2 Feb 2006 06:28:33 -0000
-@@ -157,9 +157,12 @@
- and raw_field ppf = function
-     Rpresent None -> fprintf ppf "Rpresent None"
-   | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
--  | Reither (c,tl,m,e) ->
--      fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
--        raw_type_list tl m
-+  | Reither (c,tl,m,tpl,e) ->
-+      fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,%a,@,@[<1>ref%t@])@]"
-+        c raw_type_list tl m
-+        (raw_list
-+           (fun ppf (t1,t2) ->
-+             fprintf ppf "@[%a,@,%a@]" raw_type t1 raw_type t2)) tpl
-         (fun ppf ->
-           match !e with None -> fprintf ppf " None"
-           | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
-@@ -219,8 +222,9 @@
-   List.for_all
-     (fun (_, f) ->
-        match row_field_repr f with
--       | Reither(c, l, _, _) ->
--           row.row_closed && if c then l = [] else List.length l = 1
-+       | Reither(c, l, _, pl, _) ->
-+           row.row_closed && pl = [] &&
-+           if c then l = [] else List.length l = 1
-        | _ -> true)
-     row.row_fields
- 
-@@ -392,13 +396,16 @@
- 
- and tree_of_row_field sch (l, f) =
-   match row_field_repr f with
--  | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
--  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
--  | Reither(c, tyl, _, _) ->
--      if c (* contradiction: un constructeur constant qui a un argument *)
--      then (l, true, tree_of_typlist sch tyl)
--      else (l, false, tree_of_typlist sch tyl)
--  | Rabsent -> (l, false, [] (* une erreur, en fait *))
-+  | Rpresent None | Reither(true, [], _, [], _) -> (l, false, [], [])
-+  | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty], [])
-+  | Reither(c, tyl, _, tpl, _) ->
-+      let ttpl =
-+        List.map
-+          (fun (t1,t2) -> tree_of_typexp sch t1, tree_of_typexp sch t2)
-+          tpl
-+      in
-+      (l, c && tpl = [], tree_of_typlist sch tyl, ttpl)
-+  | Rabsent -> (l, false, [], [] (* une erreur, en fait *))
- 
- and tree_of_typlist sch tyl =
-   List.map (tree_of_typexp sch) tyl
-Index: typing/typeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
-retrieving revision 1.85
-diff -u -r1.85 typeclass.ml
---- typing/typeclass.ml        22 Jul 2005 06:42:36 -0000      1.85
-+++ typing/typeclass.ml        2 Feb 2006 06:28:33 -0000
-@@ -727,7 +727,7 @@
-         {pexp_loc = loc; pexp_desc =
-          Pexp_match({pexp_loc = loc; pexp_desc =
-                      Pexp_ident(Longident.Lident"*opt*")},
--                    scases)} in
-+                    scases, false)} in
-       let sfun =
-         {pcl_loc = scl.pcl_loc; pcl_desc =
-          Pcl_fun(l, None, {ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.178
-diff -u -r1.178 typecore.ml
---- typing/typecore.ml 6 Jan 2006 02:25:37 -0000       1.178
-+++ typing/typecore.ml 2 Feb 2006 06:28:33 -0000
-@@ -156,15 +156,21 @@
-       let field = row_field tag row in
-       begin match field with
-       | Rabsent -> assert false
--      | Reither (true, [], _, e) when not row.row_closed ->
--          set_row_field e (Rpresent None)
--      | Reither (false, ty::tl, _, e) when not row.row_closed ->
-+      | Reither (true, [], _, tpl, e) when not row.row_closed ->
-+          set_row_field e (Rpresent None);
-+          List.iter
-+            (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
-+            tpl
-+      | Reither (false, ty::tl, _, tpl, e) when not row.row_closed ->
-           set_row_field e (Rpresent (Some ty));
-+          List.iter
-+            (fun (t1,t2) -> unify_pat pat.pat_env {pat with pat_type=t1} t2)
-+            tpl;
-           begin match opat with None -> assert false
-           | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl)
-           end
--      | Reither (c, l, true, e) when not row.row_fixed ->
--          set_row_field e (Reither (c, [], false, ref None))
-+      | Reither (c, l, true, tpl, e) when not row.row_fixed ->
-+          set_row_field e (Reither (c, [], false, [], ref None))
-       | _ -> ()
-       end;
-       (* Force check of well-formedness *)
-@@ -307,13 +313,13 @@
-         match row_field_repr f with
-           Rpresent None ->
-             (l,None) :: pats,
--            (l, Reither(true,[], true, ref None)) :: fields
-+            (l, Reither(true,[], true, [], ref None)) :: fields
-         | Rpresent (Some ty) ->
-             bound := ty :: !bound;
-             (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
-                       pat_type=ty})
-             :: pats,
--            (l, Reither(false, [ty], true, ref None)) :: fields
-+            (l, Reither(false, [ty], true, [], ref None)) :: fields
-         | _ -> pats, fields)
-       ([],[]) fields in
-   let row =
-@@ -337,6 +343,18 @@
-           pat pats in
-       rp { r with pat_loc = loc }
- 
-+let rec flatten_or_pat pat =
-+  match pat.pat_desc with
-+    Tpat_or (p1, p2, _) ->
-+      flatten_or_pat p1 @ flatten_or_pat p2
-+  | _ ->
-+      [pat]
-+
-+let all_variants pat =
-+  List.for_all
-+    (function {pat_desc=Tpat_variant _} -> true | _ -> false)
-+    (flatten_or_pat pat)
-+
- let rec find_record_qual = function
-   | [] -> None
-   | (Longident.Ldot (modname, _), _) :: _ -> Some modname
-@@ -423,7 +441,7 @@
-       let arg = may_map (type_pat env) sarg in
-       let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
-       let row = { row_fields =
--                    [l, Reither(arg = None, arg_type, true, ref None)];
-+                    [l, Reither(arg = None, arg_type, true, [], ref None)];
-                   row_bound = arg_type;
-                   row_closed = false;
-                   row_more = newvar ();
-@@ -788,7 +806,7 @@
-        newty (Tarrow(p, type_option (newvar ()), type_approx env e, Cok))
-   | Pexp_function (p,_,(_,e)::_) ->
-        newty (Tarrow(p, newvar (), type_approx env e, Cok))
--  | Pexp_match (_, (_,e)::_) -> type_approx env e
-+  | Pexp_match (_, (_,e)::_, false) -> type_approx env e
-   | Pexp_try (e, _) -> type_approx env e
-   | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l))
-   | Pexp_ifthenelse (_,e,_) -> type_approx env e
-@@ -939,17 +957,26 @@
-         exp_loc = sexp.pexp_loc;
-         exp_type = ty_res;
-         exp_env = env }
--  | Pexp_match(sarg, caselist) ->
-+  | Pexp_match(sarg, caselist, multi) ->
-       let arg = type_exp env sarg in
-       let ty_res = newvar() in
-       let cases, partial =
--        type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist
-+        type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi
-       in
-       re {
-         exp_desc = Texp_match(arg, cases, partial);
-         exp_loc = sexp.pexp_loc;
-         exp_type = ty_res;
-         exp_env = env }
-+  | Pexp_multifun caselist ->
-+      let ty_arg = newvar() and ty_res = newvar() in
-+      let cases, partial =
-+        type_cases env ty_arg ty_res (Some sexp.pexp_loc) caselist ~multi:true
-+      in
-+      { exp_desc = Texp_function (cases, partial);
-+        exp_loc = sexp.pexp_loc;
-+        exp_type = newty (Tarrow ("", ty_arg, ty_res, Cok));
-+        exp_env = env }
-   | Pexp_try(sbody, caselist) ->
-       let body = type_exp env sbody in
-       let cases, _ =
-@@ -1758,7 +1785,7 @@
-         {pexp_loc = loc; pexp_desc =
-          Pexp_match({pexp_loc = loc; pexp_desc =
-                      Pexp_ident(Longident.Lident"*opt*")},
--                    scases)} in
-+                    scases, false)} in
-       let sfun =
-         {pexp_loc = sexp.pexp_loc; pexp_desc =
-          Pexp_function(l, None,[{ppat_loc = loc; ppat_desc = Ppat_var"*opt*"},
-@@ -1864,7 +1891,8 @@
- 
- (* Typing of match cases *)
- 
--and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
-+and type_cases ?in_function ?(multi=false)
-+    env ty_arg ty_res partial_loc caselist =
-   let ty_arg' = newvar () in
-   let pattern_force = ref [] in
-   let pat_env_list =
-@@ -1898,10 +1926,64 @@
-   let cases =
-     List.map2
-       (fun (pat, ext_env) (spat, sexp) ->
--        let exp = type_expect ?in_function ext_env sexp ty_res in
--        (pat, exp))
--      pat_env_list caselist
--  in
-+        let add_variant_case lab row ty_res ty_res' =
-+          let fi = List.assoc lab (row_repr row).row_fields in
-+          begin match row_field_repr fi with
-+            Reither (c, _, m, _, e) ->
-+              let row' =
-+                { row_fields =
-+                  [lab, Reither(c,[],false,[ty_res,ty_res'], ref None)];
-+                  row_more = newvar (); row_bound = [ty_res; ty_res'];
-+                  row_closed = false; row_fixed = false; row_name = None }
-+              in
-+              unify_pat ext_env {pat with pat_type= newty (Tvariant row)}
-+                (newty (Tvariant row'))
-+          | _ ->
-+              unify_exp ext_env
-+                { exp_desc = Texp_tuple []; exp_type = ty_res;
-+                  exp_env = ext_env; exp_loc = sexp.pexp_loc }
-+                ty_res'
-+          end
-+        in
-+        pat,
-+        match pat.pat_desc with
-+          _ when multi && all_variants pat ->
-+            let ty_res' = newvar () in
-+            List.iter
-+              (function {pat_desc=Tpat_variant(lab,_,row)} ->
-+                add_variant_case lab row ty_res ty_res'
-+              | _ -> assert false)
-+              (flatten_or_pat pat);
-+            type_expect ?in_function ext_env sexp ty_res'
-+        | Tpat_alias (p, id) when multi && all_variants p ->
-+            let vd = Env.find_value (Path.Pident id) ext_env in
-+            let row' =
-+              match repr vd.val_type with
-+                {desc=Tvariant row'} -> row'
-+              | _ -> assert false
-+            in
-+            begin_def ();
-+            let tv = newvar () in
-+            let env = Env.add_value id {vd with val_type=tv} ext_env in
-+            let exp = type_exp env sexp in
-+            end_def ();
-+            generalize exp.exp_type;
-+            generalize tv;
-+            List.iter
-+              (function {pat_desc=Tpat_variant(lab,_,row)}, [tv'; ty'] ->
-+                let fi' = List.assoc lab (row_repr row').row_fields in
-+                let row' =
-+                  {row' with row_fields=[lab,fi']; row_more=newvar()} in
-+                unify_pat ext_env {pat with pat_type=tv'}
-+                  (newty (Tvariant row'));
-+                add_variant_case lab row ty_res ty'
-+              | _ -> assert false)
-+              (List.map (fun p -> p, instance_list [tv; exp.exp_type])
-+                 (flatten_or_pat p));
-+            {exp with exp_type = instance exp.exp_type}
-+        | _ ->
-+            type_expect ?in_function ext_env sexp ty_res)
-+      pat_env_list caselist in
-   let partial =
-     match partial_loc with None -> Partial
-     | Some loc -> Parmatch.check_partial loc cases
-Index: typing/typedecl.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedecl.ml,v
-retrieving revision 1.75
-diff -u -r1.75 typedecl.ml
---- typing/typedecl.ml 16 Aug 2005 00:48:56 -0000      1.75
-+++ typing/typedecl.ml 2 Feb 2006 06:28:33 -0000
-@@ -432,8 +432,10 @@
-               match Btype.row_field_repr f with
-                 Rpresent (Some ty) ->
-                   compute_same ty
--              | Reither (_, tyl, _, _) ->
--                  List.iter compute_same tyl
-+              | Reither (_, tyl, _, tpl, _) ->
-+                  List.iter compute_same tyl;
-+                  List.iter (compute_variance_rec true true true)
-+                    (List.map fst tpl @ List.map snd tpl)
-               | _ -> ())
-             row.row_fields;
-           compute_same row.row_more
-@@ -856,8 +858,8 @@
-               explain row.row_fields
-                 (fun (l,f) -> match Btype.row_field_repr f with
-                   Rpresent (Some t) -> t
--                | Reither (_,[t],_,_) -> t
--                | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl)
-+                | Reither (_,[t],_,_,_) -> t
-+                | Reither (_,tl,_,_,_) -> Btype.newgenty (Ttuple tl)
-                 | _ -> Btype.newgenty (Ttuple[]))
-                 "case" (fun (lab,_) -> "`" ^ lab ^ " of ")
-           | _ -> trivial ty'
-Index: typing/types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- typing/types.ml    9 Dec 2004 12:40:53 -0000       1.25
-+++ typing/types.ml    2 Feb 2006 06:28:33 -0000
-@@ -48,7 +48,9 @@
- 
- and row_field =
-     Rpresent of type_expr option
--  | Reither of bool * type_expr list * bool * row_field option ref
-+  | Reither of
-+      bool * type_expr list * bool *
-+      (type_expr * type_expr) list * row_field option ref
-   | Rabsent
- 
- and abbrev_memo =
-Index: typing/types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- typing/types.mli   9 Dec 2004 12:40:53 -0000       1.25
-+++ typing/types.mli   2 Feb 2006 06:28:33 -0000
-@@ -47,7 +47,9 @@
- 
- and row_field =
-     Rpresent of type_expr option
--  | Reither of bool * type_expr list * bool * row_field option ref
-+  | Reither of
-+      bool * type_expr list * bool *
-+      (type_expr * type_expr) list * row_field option ref
-         (* 1st true denotes a constant constructor *)
-         (* 2nd true denotes a tag in a pattern matching, and
-            is erased later *)
-Index: typing/typetexp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
-retrieving revision 1.54
-diff -u -r1.54 typetexp.ml
---- typing/typetexp.ml 22 Jul 2005 06:42:36 -0000      1.54
-+++ typing/typetexp.ml 2 Feb 2006 06:28:33 -0000
-@@ -207,9 +207,9 @@
-                 match Btype.row_field_repr f with
-                 | Rpresent (Some ty) ->
-                     bound := ty :: !bound;
--                    Reither(false, [ty], false, ref None)
-+                    Reither(false, [ty], false, [], ref None)
-                 | Rpresent None ->
--                    Reither (true, [], false, ref None)
-+                    Reither (true, [], false, [], ref None)
-                 | _ -> f)
-               row.row_fields
-           in
-@@ -273,13 +273,16 @@
-           (l, f) :: fields
-       in
-       let rec add_field fields = function
--          Rtag (l, c, stl) ->
-+          Rtag (l, c, stl, stpl) ->
-             name := None;
-             let f = match present with
-               Some present when not (List.mem l present) ->
--                let tl = List.map (transl_type env policy) stl in
--                bound := tl @ !bound;
--                Reither(c, tl, false, ref None)
-+                let transl_list = List.map (transl_type env policy) in
-+                let tl = transl_list stl in
-+                let stpl1, stpl2 = List.split stpl in
-+                let tpl1 = transl_list stpl1 and tpl2 = transl_list stpl2 in
-+                bound := tl @ tpl1 @ tpl2 @ !bound;
-+                Reither(c, tl, false, List.combine tpl1 tpl2, ref None)
-             | _ ->
-                 if List.length stl > 1 || c && stl <> [] then
-                   raise(Error(styp.ptyp_loc, Present_has_conjunction l));
-@@ -311,9 +314,9 @@
-                     begin match f with
-                       Rpresent(Some ty) ->
-                         bound := ty :: !bound;
--                        Reither(false, [ty], false, ref None)
-+                        Reither(false, [ty], false, [], ref None)
-                     | Rpresent None ->
--                        Reither(true, [], false, ref None)
-+                        Reither(true, [], false, [], ref None)
-                     | _ ->
-                         assert false
-                     end
-@@ -406,7 +409,8 @@
-               {row with row_fixed=true;
-                row_fields = List.map
-                  (fun (s,f as p) -> match Btype.row_field_repr f with
--                   Reither (c, tl, m, r) -> s, Reither (c, tl, true, r)
-+                   Reither (c, tl, m, tpl, r) ->
-+                     s, Reither (c, tl, true, tpl, r)
-                  | _ -> p)
-                  row.row_fields};
-         Btype.iter_row make_fixed_univars row
-Index: typing/unused_var.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
-retrieving revision 1.5
-diff -u -r1.5 unused_var.ml
---- typing/unused_var.ml       4 Jan 2006 16:55:50 -0000       1.5
-+++ typing/unused_var.ml       2 Feb 2006 06:28:33 -0000
-@@ -122,9 +122,11 @@
-   | Pexp_apply (e, lel) ->
-       expression ppf tbl e;
-       List.iter (fun (_, e) -> expression ppf tbl e) lel;
--  | Pexp_match (e, pel) ->
-+  | Pexp_match (e, pel, _) ->
-       expression ppf tbl e;
-       match_pel ppf tbl pel;
-+  | Pexp_multifun pel ->
-+      match_pel ppf tbl pel;
-   | Pexp_try (e, pel) ->
-       expression ppf tbl e;
-       match_pel ppf tbl pel;
-Index: bytecomp/matching.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/matching.ml,v
-retrieving revision 1.67
-diff -u -r1.67 matching.ml
---- bytecomp/matching.ml       7 Sep 2005 16:07:48 -0000       1.67
-+++ bytecomp/matching.ml       2 Feb 2006 06:28:33 -0000
-@@ -1991,7 +1991,7 @@
-     List.iter
-       (fun (_, f) ->
-         match Btype.row_field_repr f with
--          Rabsent | Reither(true, _::_, _, _) -> ()
-+          Rabsent | Reither(true, _::_, _, _, _) -> ()
-         | _ -> incr num_constr)
-       row.row_fields
-   else
-Index: toplevel/genprintval.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/toplevel/genprintval.ml,v
-retrieving revision 1.38
-diff -u -r1.38 genprintval.ml
---- toplevel/genprintval.ml    13 Jun 2005 04:55:53 -0000      1.38
-+++ toplevel/genprintval.ml    2 Feb 2006 06:28:33 -0000
-@@ -293,7 +293,7 @@
-                   | (l, f) :: fields ->
-                       if Btype.hash_variant l = tag then
-                         match Btype.row_field_repr f with
--                        | Rpresent(Some ty) | Reither(_,[ty],_,_) ->
-+                        | Rpresent(Some ty) | Reither(_,[ty],_,_,_) ->
-                             let args =
-                               tree_of_val (depth - 1) (O.field obj 1) ty in
-                             Oval_variant (l, Some args)

diff --git a/testlabl/multimatch.ml b/testlabl/multimatch.ml
deleted file mode 100644 (file)
index 7c9aa73..0000000
--- a/testlabl/multimatch.ml
+++ /dev/null
@@ -1,158 +0,0 @@
-(* Simple example *)
-let f x =
-  (multimatch x with `A -> 1 | `B -> true),
-  (multimatch x with `A -> 1. | `B -> "1");;
-
-(* OK *)
-module M : sig
-  val f :
-    [< `A & 'a = int & 'b = float | `B &   'b =string & 'a =  bool] -> 'a * 'b
-end = struct let f = f end;;
-
-(* Bad *)
-module M : sig
-  val f :
-    [< `A & 'a = int & 'b = float | `B &   'b =string & 'a =   int] -> 'a * 'b
-end = struct let f = f end;;
-
-(* Should be good! *)
-module M : sig
-  val f :
-    [< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
-end = struct let f = f end;;
-
-let f = multifun `A|`B as x -> f x;;
-
-(* Two-level example *)
-let f = multifun
-    `A -> (multifun `C -> 1 | `D -> 1.)
-  | `B -> (multifun `C -> true | `D -> "1");;
-
-(* OK *)
-module M : sig
-  val f :
-    [< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
-     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-(* Bad *)
-module M : sig
-  val f :
-    [< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
-     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-module M : sig
-  val f :
-    [< `A & 'b = [< `C & 'a = int | `D] -> 'a
-     | `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
-end = struct let f = f end;;
-
-
-(* Examples with hidden sharing *)
-let r = ref []
-let f = multifun `A -> 1 | `B -> true
-let g x = r := [f x];;
-
-(* Bad! *)
-module M : sig
-  val g : [< `A & 'a = int | `B & 'a = bool] -> unit
-end = struct let g = g end;;
-
-let r = ref []
-let f = multifun `A -> r | `B -> ref [];;
-(* Now OK *)
-module M : sig
-  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
-end = struct let f = f end;;
-(* Still OK *)
-let l : int list ref = r;;
-module M : sig
-  val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
-end = struct let f = f end;;
-
-
-(* Examples that would need unification *)
-let f = multifun `A -> (1, []) | `B -> (true, [])
-let g x = fst (f x);;
-(* Didn't work, now Ok *)
-module M : sig
-  val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
-end = struct let g = g end;;
-let g = multifun (`A|`B) as x -> g x;;
-
-(* Other examples *)
-
-let f x =
-  let a = multimatch x with `A -> 1 | `B -> "1" in
-  (multifun `A -> print_int | `B -> print_string) x a
-;;
-
-let f = multifun (`A|`B) as x -> f x;;
-
-type unit_op = [`Set of int | `Move of int]
-type int_op = [`Get]
-
-let op r =
-  multifun
-    `Get     -> !r
-  | `Set x   -> r := x
-  | `Move dx -> r := !r + dx
-;;
-
-let rec trace r = function
-    [] -> []
-  | op1 :: ops ->
-      multimatch op1 with
-        #int_op as op1 ->
-          let x = op r op1 in
-          x :: trace r ops
-      | #unit_op as op1 ->
-          op r op1;
-          trace r ops
-;;
-
-class point x = object
-  val mutable x : int = x
-  method get = x
-  method set y = x <- y
-  method move dx = x <- x + dx
-end;;
-
-let poly sort coeffs x =
-  let add, mul, zero =
-    multimatch sort with
-      `Int -> (+), ( * ), 0
-    | `Float -> (+.), ( *. ), 0.
-  in
-  let rec compute = function
-      []     -> zero
-    | c :: cs -> add c (mul x (compute cs))
-  in
-  compute coeffs
-;;
-
-module M : sig
-  val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
-end = struct let poly = poly end;;
-
-type ('a,'b) num_sort =
-  'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
-module M : sig
-  val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
-end = struct let poly = poly end;;
-
-
-(* type dispatch *)
-
-type num = [ `Int | `Float ]
-let print0 = multifun
-    `Int -> print_int
-  | `Float -> print_float
-;;
-let print1 = multifun
-    #num as x -> print0 x
-  | `List t -> List.iter (print0 t)
-  | `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
-;;
-print1 (`Pair(`Int,`Float)) (1,1.0);;

diff --git a/testlabl/newlabels.ps b/testlabl/newlabels.ps
deleted file mode 100644 (file)
index 01eac19..0000000
--- a/testlabl/newlabels.ps
+++ /dev/null
@@ -1,1458 +0,0 @@
-%!PS-Adobe-2.0
-%%Creator: dvipsk 5.78 p1.4 Copyright 1996-98 ASCII Corp.(www-ptex@ascii.co.jp)
-%%dvipsk 5.78 Copyright 1998 Radical Eye Software (www.radicaleye.com)
-%%Title: newlabels.dvi
-%%Pages: 2 0
-%%PageOrder: Ascend
-%%BoundingBox: 0 0 596 842
-%%EndComments
-%%BeginProcSet: PStoPS 1 15
-userdict begin
-[/showpage/erasepage/copypage]{dup where{pop dup load
- type/operatortype eq{1 array cvx dup 0 3 index cvx put
- bind def}{pop}ifelse}{pop}ifelse}forall
-[/letter/legal/executivepage/a4/a4small/b5/com10envelope
- /monarchenvelope/c5envelope/dlenvelope/lettersmall/note
- /folio/quarto/a5]{dup where{dup wcheck{exch{}put}
- {pop{}def}ifelse}{pop}ifelse}forall
-/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put}
- {pop def}ifelse}{def}ifelse
-/PStoPSmatrix matrix currentmatrix def
-/PStoPSxform matrix def/PStoPSclip{clippath}def
-/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def
-/initmatrix{matrix defaultmatrix setmatrix}bind def
-/initclip[{matrix currentmatrix PStoPSmatrix setmatrix
- [{currentpoint}stopped{$error/newerror false put{newpath}}
- {/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse]
- {[/newpath cvx{/moveto cvx}{/lineto cvx}
- {/curveto cvx}{/closepath cvx}pathforall]cvx exch pop}
- stopped{$error/errorname get/invalidaccess eq{cleartomark
- $error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop
- /initclip dup load dup type dup/operatortype eq{pop exch pop}
- {dup/arraytype eq exch/packedarraytype eq or
-  {dup xcheck{exch pop aload pop}{pop cvx}ifelse}
-  {pop cvx}ifelse}ifelse
- {newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def
-/initgraphics{initmatrix newpath initclip 1 setlinewidth
- 0 setlinecap 0 setlinejoin []0 setdash 0 setgray
- 10 setmiterlimit}bind def
-end
-%%EndProcSet
-%DVIPSCommandLine: dvips -f newlabels
-%DVIPSParameters: dpi=300
-%DVIPSSource:  TeX output 1999.10.26:1616
-%%BeginProcSet: tex.pro
-%!
-/TeXDict 300 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
-/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
-mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
-ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
-isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
-hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
-TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
-forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
-/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
-/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
-/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
-string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
-end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
-/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
-N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
-length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
-128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
-get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
-dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
-/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
-/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
-0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
-setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
-.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
-if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
-length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
-cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
-0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
-add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
-/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
-known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
-/IE 256 array N 2 string 0 1 255{IE S dup 360 add 36 4 index cvrs cvn
-put}for pop 65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N
-/RMat[1 0 0 -1 0 0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley
-X /rulex X V}B /V{}B /RV statusdict begin /product where{pop false[
-(Display)(NeXT)(LaserWriter 16/600)]{dup length product length le{dup
-length product exch 0 exch getinterval eq{pop true exit}if}{pop}ifelse}
-forall}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
-RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
-false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
-round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
-rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
-{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
-B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
-4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
-p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
-a}B /bos{/SS save N}B /eos{SS restore}B end
-
-%%EndProcSet
-TeXDict begin 39158280 55380996 1000 300 300 (newlabels.dvi)
-@start
-%DVIPSBitmapFont: Fa cmr6 6 2
-/Fa 2 51 df<187898181818181818181818181818FF08107D8F0F> 49
-D<1F00618040C08060C0600060006000C00180030006000C00102020207FC0FFC00B107F
-8F0F> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fb cmmi8 8 4
-/Fb 4 111 df<FFC0FF1C00181C00101C00101C00103800203800203800203800207000
-40700040700040700040E00080E00080E00080E00080E00100E00200E004006008003830
-000FC00018177E9618> 85 D<0300038003000000000000000000000000001C00240046
-0046008C000C0018001800180031003100320032001C0009177F960C> 105
-D<383C1E0044C6630047028100460301008E0703000C0603000C0603000C060300180C06
-00180C0620180C0C20180C0C40301804C0301807001B0E7F8D1F> 109
-D<383C0044C6004702004602008E06000C06000C06000C0600180C00180C401818401818
-80300980300E00120E7F8D15> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fc cmbx8 8 4
-/Fc 4 111 df<01800780FF80FF80078007800780078007800780078007800780078007
-800780078007800780FFF8FFF80D157D9414> 49 D<387C7C7C3800000000FCFC3C3C3C
-3C3C3C3C3C3C3C3CFFFF08187F970B> 105 D<FC7E0FC0FD8730E03E07C0F03E07C0F03C
-0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F03C0780F0FF
-1FE3FCFF1FE3FC1E0F7E8E23> 109 D<FC7C00FD8E003E0F003E0F003C0F003C0F003C0F
-003C0F003C0F003C0F003C0F003C0F003C0F00FF3FC0FF3FC0120F7E8E17> I
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fd cmsy8 8 3
-/Fd 3 93 df<FFFFF0FFFFF014027D881B> 0 D<020002000200C218F2783AE00F800F80
-3AE0F278C2180200020002000D0E7E8E12> 3 D<03F8001FFF003C07806000C0C00060C0
-0060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C00060C0
-006040002013137E9218> 92 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fe cmtt12 12 43
-/Fe 43 125 df<01818003C3C003C3C003C3C003C3C003C3C003C3C07FFFF0FFFFF8FFFF
-F87FFFF00787800787800787800F8F800F0F000F0F000F0F000F0F007FFFF0FFFFF8FFFF
-F87FFFF01E1E001E1E001E1E001E1E001E1E001E1E000C0C00151E7E9D1A> 35
-D<00E00003F00007F8000738000E1C000E1C000E1C000E1C000E38000E39FC0E71FC07F1
-FC07E1C007C1C00781C00783800F83801FC3803DC70078E70070EE00E07E00E07E00E03C
-08E03C1CE07E1C70FF1C7FE7F83FC3F80F00E0161E7F9D1A> 38
-D<0038007800F001E003C007800F000E001C001C0038003800700070007000E000E000E0
-00E000E000E000E000E000E000E000700070007000380038001C001C000E000F00078003
-C001E000F8007800380D2878A21A> 40 D<6000F00078003C001E000F000780038001C0
-01C000E000E0007000700070003800380038003800380038003800380038003800700070
-007000E000E001C001C0038007800F001E003C007800F00060000D287CA21A> I<7FFFC0
-FFFFE0FFFFE07FFFC013047D901A> 45 D<00C001C001C003C007C00FC07FC0FDC071C0
-01C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C0
-7FFF7FFF7FFF101E7B9D1A> 49 D<03F8000FFE001FFF803C07C07801E07000E0E00070
-F00070F000706000700000700000700000E00000E00001C00003C0000780000F00001E00
-003C0000780000F00003E00007C0000F00001E00703C00707FFFF0FFFFF07FFFF0141E7D
-9D1A> I<03FC000FFF003FFFC03C03E07800E07800707800700000700000700000E00001
-E00007C003FF8003FF0003FFC00003E00000E0000070000078000038000038600038F000
-38F00078E000707000E07E03E03FFFC00FFF0001FC00151E7E9D1A> I<01FC0007FF001F
-FFC01F07C03C01E07800F07000707000707000707800F03800E01E03C00FFF8003FE0007
-FF001F8FC03C01E07800F0700070E00038E00038E00038E00038F000787000707800F03E
-03E01FFFC007FF0001FC00151E7E9D1A> 56 D<01F00007FC001FFE003E0F0038078070
-03807001C0E001C0E001C0E001E0E000E0E000E0E001E07001E07803E03C0FE01FFFE00F
-FCE003F0E00001C00001C00001C0000380600380F00700F00F00F03E007FFC003FF0000F
-C000131E7D9D1A> I<3078FCFC78300000000000000000003078FCFC7830061576941A>
-I<183C7E7E3C18000000000000000000183C7E7E3E1E0E0E1C3CF8F060071C77941A> I<
-0000C00003E00007E0000FC0003F80007E0000FC0003F80007E0000FC0003F80007E0000
-FC0000FC00007E00003F80000FC00007E00003F80000FC00007E00003F80000FC00007E0
-0003E00000C0131A7D9B1A> I<7FFFF0FFFFF8FFFFF87FFFF00000000000000000000000
-007FFFF0FFFFF8FFFFF87FFFF0150C7E941A> I<600000F80000FC00007E00003F80000F
-C00007E00003F80000FC00007E00003F80000FC00007E00007E0000FC0003F80007E0000
-FC0003F80007E0000FC0003F80007E0000FC0000F80000600000131A7D9B1A> I<007C38
-01FF3807FFF80F83F81E00F81C0078380078380038700038700038700000E00000E00000
-E00000E00000E00000E00000E00000E000007000007000387000383800383800381C0070
-1E00F00F83E007FFC001FF80007C00151E7E9D1A> 67 D<FE03FEFF03FEFF03FE1D8070
-1D80701DC0701CC0701CC0701CE0701CE0701C60701C70701C70701C30701C38701C3870
-1C18701C1C701C1C701C0C701C0E701C0E701C06701C06701C07701C03701C0370FF81F0
-FF81F0FF80F0171E7F9D1A> 78 D<03F8E00FFEE01FFFE03C07E07801E0F001E0E000E0
-E000E0E000E0E000007000007800003F80001FF80007FF00007FC00007E00000F0000070
-000038000038600038E00038E00038E00070F000F0FE01E0FFFFC0EFFF80E1FE00151E7E
-9D1A> 83 D<7FFFFEFFFFFEFFFFFEE0380EE0380EE0380EE0380E003800003800003800
-003800003800003800003800003800003800003800003800003800003800003800003800
-00380000380000380000380000380003FF8003FF8003FF80171E7F9D1A> I<FFFCFFFCFF
-FCE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E0
-00E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000FFFCFFFCFF
-FC0E2776A21A> 91 D<FFFCFFFCFFFC001C001C001C001C001C001C001C001C001C001C
-001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C
-001C001C001C001C001CFFFCFFFCFFFC0E277FA21A> 93 D<1FF0003FFC007FFE00780F
-00300700000380000380007F8007FF801FFF803F8380780380700380E00380E00380E003
-80700780780F803FFFFC1FFDFC07F0FC16157D941A> 97 D<7E0000FE00007E00000E00
-000E00000E00000E00000E00000E00000E3E000EFF800FFFE00FC1F00F80700F00380E00
-380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
-C00EFF80063E00161E7F9D1A> I<00FF8003FFC00FFFE01F01E03C00C078000070000070
-0000E00000E00000E00000E00000E000007000007000007800703C00701F01F00FFFE003
-FFC000FE0014157D941A> I<000FC0001FC0000FC00001C00001C00001C00001C00001C0
-0001C001F1C007FDC00FFFC01E0FC03C07C07803C07001C0E001C0E001C0E001C0E001C0
-E001C0E001C0E001C07003C07003C03807C03E0FC01FFFF807FDFC01F1F8161E7E9D1A>
-I<01F80007FF000FFF801E07C03C01C07800E07000E0E00070E00070FFFFF0FFFFF0FFFF
-F0E000007000007000007800703C00701F01F00FFFE003FF8000FE0014157D941A> I<00
-07E0001FF0003FF800787800F03000E00000E00000E00000E0007FFFF0FFFFF0FFFFF000
-E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000
-E00000E00000E0003FFF807FFFC03FFF80151E7F9D1A> I<7E0000FE00007E00000E0000
-0E00000E00000E00000E00000E00000E3E000EFF800FFFC00FC1C00F80E00F00E00E00E0
-0E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E07FC3FC
-FFE7FE7FC3FC171E7F9D1A> 104 D<00C00001E00001E00000C000000000000000000000
-0000000000000000007FE0007FE0007FE00000E00000E00000E00000E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFF80FFFFC07FFF80
-121F7C9E1A> I<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0131E7D9D1A> 108
-D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C001C1C1C001C1C1C
-001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
-007F1F1F00FFBFBF807F1F1F00191580941A> I<7E3E00FEFF807FFFC00FC1C00F80E00F
-00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E
-00E07FC3FCFFE7FE7FC3FC17157F941A> I<01F00007FC001FFF003E0F803C07807803C0
-7001C0E000E0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F80
-1FFF0007FC0001F00013157D941A> I<7E3E00FEFF807FFFE00FC1F00F80700F00380E00
-380E001C0E001C0E001C0E001C0E001C0E001C0E001C0F00380F00780F80F00FC1E00FFF
-C00EFF800E3E000E00000E00000E00000E00000E00000E00000E00000E00007FC000FFE0
-007FC00016207F941A> I<7F81F8FF8FFC7F9FFE03FE1E03F80C03E00003E00003C00003
-80000380000380000380000380000380000380000380000380000380007FFF00FFFF007F
-FF0017157F941A> 114 D<07FB801FFF807FFF80780780E00380E00380E003807800007F
-C0001FFC0007FE00003F800007806001C0E001C0E001C0F003C0FC0780FFFF00EFFE00E3
-F80012157C941A> I<0180000380000380000380000380000380000380007FFFE0FFFFE0
-FFFFE0038000038000038000038000038000038000038000038000038000038000038070
-03807003807003807001C1E001FFE000FF80003F00141C7F9B1A> I<7E07E0FE0FE07E07
-E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
-E00E00E00E01E00F03E007FFFC03FFFE00FCFC17157F941A> I<7F83FCFFC7FE7F83FC0E
-00E00E00E00E00E00701C00701C00701C003838003838003838001C70001C70001C70000
-EE0000EE0000EE00007C00007C0000380017157F941A> I<FF83FEFF83FEFF83FE380038
-3800381C00701C00701C00701C38701C7C701C7C700C6C600EEEE00EEEE00EEEE00EEEE0
-0EC6E006C6C007C7C00783C00783C017157F941A> I<7FC7F87FCFFC7FC7F80703C00383
-8003C70001EF0000FE00007C00007800003800007C0000EE0001EE0001C7000383800783
-C00F01C07FC7FCFFC7FE7FC7FC17157F941A> I<7F83FCFFC7FE7F83FC0E00E00E00E007
-00E00701C00701C00381C003838003C38001C38001C70000E70000E70000E60000660000
-6E00003C00003C00003C0000380000380000380000700000700030F00078E00071E0007F
-C0003F80001E000017207F941A> I<60F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0
-F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F060042775A21A> 124 D
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Ff cmr8 8 3
-/Ff 3 51 df<003000003000003000003000003000003000003000003000003000003000
-003000FFFFFCFFFFFC003000003000003000003000003000003000003000003000003000
-00300000300016187E931B> 43 D<06000E00FE000E000E000E000E000E000E000E000E
-000E000E000E000E000E000E000E000E000E00FFE00B157D9412> 49
-D<0F8030E040708030C038E0384038003800700070006000C00180030006000C08080810
-183FF07FF0FFF00D157E9412> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fg cmmi12 12 13
-/Fg 13 121 df<0FFFF81FFFFC3FFFF870200040200080200080600000600000600000C0
-0000C00000C00000C00001C0000180000180000380000380000380000700000300001615
-7E9415> 28 D<0000100000002000000020000000200000002000000040000000400000
-004000000040000000800000008000000080000000800000010000000FE00000711C0001
-C10600030203000E0203801C020180180201C0380401C0700401C0700401C0700401C0E0
-080380E0080380E00807006008070070100E0030101C00301038001C10E0000623800001
-FE0000002000000020000000400000004000000040000000400000008000000080000000
-800000008000001A2D7EA21D> 30 D<70F8F8F87005057C840E> 58
-D<70F8FCFC7404040404080810102040060F7C840E> I<00008000018000018000030000
-0300000300000600000600000600000C00000C00000C0000180000180000180000300000
-300000300000600000600000600000C00000C00000C00001800001800001800001800003
-00000300000300000600000600000600000C00000C00000C000018000018000018000030
-0000300000300000600000600000600000C00000C00000C0000011317DA418> 61
-D<00FFFC00000F8000000F0000000F0000001E0000001E0000001E0000001E0000003C00
-00003C0000003C0000003C00000078000000780000007800000078000000F0000000F000
-0000F0000000F0000001E0000001E0000001E0002001E0002003C0004003C0004003C000
-8003C0008007800180078001000780030007800F000F803E00FFFFFE001B227DA121> 76
-D<1FFFFFFE1E01E00E1801E0063001E0062003C0062003C0064003C0044003C004400780
-04800780048007800400078000000F0000000F0000000F0000000F0000001E0000001E00
-00001E0000001E0000003C0000003C0000003C0000003C00000078000000780000007800
-000078000000F0000000F0000000F0000000F0000001F000007FFFC0001F227EA11D> 84
-D<3FFE01FF8003C0003C0003C000300003C0001000078000200007800020000780002000
-07800020000F000040000F000040000F000040000F000040001E000080001E000080001E
-000080001E000080003C000100003C000100003C000100003C0001000078000200007800
-020000780002000078000200007000040000F000040000F0000800007000080000700010
-00007000200000380040000038008000001C01000000060600000001F800000021237DA1
-21> I<007E000381000700800E00801C0080380080780100700600FFF800F00000F00000
-E00000E00000E00000E00000E00080E000807003003004001838000FC00011157D9417>
-101 D<01E00FC001C001C001C0038003800380038007000700070007000E000E000E000E
-001C001C001C001C0038003800380038007000700070007080E100E100E100620062003C
-000B237EA20F> 108 D<03C0F004631C04740E08780E08700708700708700F00E00F00E0
-0F00E00F00E00F01C01E01C01E01C01E01C03C03803803803803C07003C0E0072180071E
-000700000700000E00000E00000E00000E00001C00001C00001C0000FF8000181F819418
-> 112 D<3C0F004630C04741C08783C08783C08701808700000E00000E00000E00000E00
-001C00001C00001C00001C000038000038000038000038000070000030000012157E9416
-> 114 D<01E0F006310C081A1C101A3C201C3C201C18201C000038000038000038000038
-0000700000700000700000700860E010F0E010F0E020E170404230803C1F0016157E941C
-> 120 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fh cmti12 12 22
-/Fh 22 122 df<FFF0FFF0FFE00C037C8B11> 45 D<70F8F8F0E005057A840F> I<00F8
-C00185C00705C00E03800E03801C03803C0380380700780700780700780700F00E00F00E
-00F00E00F00E10F01C20701C20703C20305C40308C400F078014157B9419> 97
-D<03C01F8003800380038007000700070007000E000E000E000E001C001CF81D0C1E0E3C
-0638073807380F700F700F700F700FE01EE01EE01EE03CE038E038607060E031C01F0010
-237BA216> I<007E0001C1000301800703800E07801C07803C0000380000780000780000
-780000F00000F00000F00000F00000F00100700100700200300C001830000FC00011157B
-9416> I<00003C0003F80000380000380000380000700000700000700000700000E00000
-E00000E00000E00001C000F9C00185C00705C00E03800E03801C03803C03803807007807
-00780700780700F00E00F00E00F00E00F00E10F01C20701C20703C20305C40308C400F07
-8016237BA219> I<00F803840E021C023C0238027804F018FFE0F000F000E000E000E000
-E000E002E0026004701830600F800F157A9416> I<00003E0000470000CF00018F000186
-000380000380000380000700000700000700000700000700000E0000FFF0000E00000E00
-000E00001C00001C00001C00001C00001C00003800003800003800003800003800007000
-00700000700000700000700000E00000E00000E00000E00000C00001C00001C000718000
-F18000F300006200003C0000182D82A20F> I<001F180030B800E0B801C07001C0700380
-700780700700E00F00E00F00E00F00E01E01C01E01C01E01C01E01C01E03800E03800E07
-80060B8006170001E700000700000700000E00000E00000E00701C00F01800F0300060E0
-003F8000151F7E9416> I<00C001E001C001C0000000000000000000000000000000001E
-002300430043008700870087000E000E001C001C001C0038003800384070807080708071
-0032001C000B217BA00F> 105 D<00F00007E00000E00000E00000E00001C00001C00001
-C00001C0000380000380000380000380000700000701E00702100704700E08F00E10F00E
-20600E40001D80001E00001FC0001C7000383800383800381C00381C2070384070384070
-3840701880E01880600F0014237DA216> 107 D<01E00FC001C001C001C0038003800380
-038007000700070007000E000E000E000E001C001C001C001C0038003800380038007000
-700070007100E200E200E200E200640038000B237CA20C> I<1C0F80F8002610C10C0047
-6066060087807807008780780700870070070087007007000E00E00E000E00E00E000E00
-E00E000E00E00E001C01C01C001C01C01C001C01C01C001C01C038203803803840380380
-70403803807080380380308070070031003003001E0023157B9428> I<380F804C30C04E
-40608E80708F00708E00708E00701C00E01C00E01C00E01C00E03801C03801C03801C038
-0384700388700308700708700310E003106001E016157B941B> I<007E0001C300038180
-0701C00E01C01C01E03C01E03801E07801E07801E07801E0F003C0F003C0F00380F00780
-700700700E00700C0030180018700007C00013157B9419> I<01C1F002621804741C0878
-0C08700E08700E08701E00E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0780380
-7003807003C0E003C1C0072380071E000700000700000E00000E00000E00000E00001C00
-001C00001C0000FFC000171F7F9419> I<1C1F002620804741C08783C08703C087018087
-00000E00000E00000E00000E00001C00001C00001C00001C000038000038000038000038
-000070000030000012157B9415> 114 D<00FC000183000200800401800C03800C03000C
-00000F00000FF00007FC0003FE00003E00000F00000700700700F00600F00600E0040040
-08002030001FC00011157D9414> I<00C001C001C001C001C003800380038003800700FF
-F8070007000E000E000E000E001C001C001C001C00380038003800381070207020704070
-8031001E000D1F7C9E10> I<1E0060E02300E0F04380E1F04381C0F08381C0708701C030
-8701C030070380200E0380200E0380200E0380201C0700401C0700401C0700401C070080
-1C0700801C0701001C0F01000C0B02000613840003E0F8001C157B9420> 119
-D<03C1E0046210083470103CF02038F020386020380000700000700000700000700000E0
-0000E00000E00000E02061C040F1C040F1C080E2C100446200383C0014157D9416> I<1E
-00302300704380704380E08380E08700E08700E00701C00E01C00E01C00E01C01C03801C
-03801C03801C03801C07001C07001C07001C0F000C3E0003CE00000E00000E00001C0060
-1C00F03800F03000E0600080C0004380003E0000141F7B9418> I
-E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fi cmbx12 12 20
-/Fi 20 122 df<FFFFFF8000FFFFFFF00007F003FC0007F0007E0007F0003F0007F0001F
-8007F0000FC007F00007E007F00007E007F00007F007F00003F007F00003F007F00003F0
-07F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807
-F00003F807F00003F807F00003F007F00003F007F00003F007F00007E007F00007E007F0
-000FC007F0001F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF800025227E
-A12B> 68 D<01FE0207FF861F01FE3C007E7C001E78000E78000EF80006F80006FC0006
-FC0000FF0000FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FE00007F
-00003F00003FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF80
-18227DA11F> 83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003
-F80180E003F801C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F8
-00000003F800000003F800000003F800000003F800000003F800000003F800000003F800
-000003F800000003F800000003F800000003F800000003F800000003F800000003F80000
-0003F800000003F800000003F800000003F800000003F8000001FFFFF00001FFFFF00022
-227EA127> I<0FFC003FFF807E07C07E03E07E01E07E01F03C01F00001F00001F0003FF0
-03FDF01FC1F03F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F
-18167E951B> 97 D<FF000000FF0000001F0000001F0000001F0000001F0000001F0000
-001F0000001F0000001F0000001F0000001F0000001F0000001F0FE0001F3FF8001FE07C
-001F803E001F001F001F000F801F000F801F000FC01F000FC01F000FC01F000FC01F000F
-C01F000FC01F000FC01F000FC01F000F801F001F801F801F001FC03E001EE07C001C3FF8
-00180FC0001A237EA21F> I<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000
-FC0000FC0000FC0000FC0000FC0000FC00007C00007E00007E00003E00181F00300FC060
-07FFC000FF0015167E9519> I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00
-F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC0
-7003FFC000FF0015167E951A> 101 D<001FC0007FE000F1F001E3F003E3F007C3F007C1
-E007C00007C00007C00007C00007C00007C000FFFE00FFFE0007C00007C00007C00007C0
-0007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C0
-0007C00007C0003FFC003FFC00142380A211> I<01FE0F0007FFBF800F87C7801F03E780
-1E01E0003E01F0003E01F0003E01F0003E01F0003E01F0001E01E0001F03E0000F87C000
-0FFF800009FE000018000000180000001C0000001FFFE0000FFFF80007FFFE001FFFFF00
-3C003F0078000F80F0000780F0000780F0000780F000078078000F003C001E001F007C00
-0FFFF80001FFC00019217F951C> I<1C003E007F007F007F003E001C0000000000000000
-00000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F00FFE0FFE00B247EA310> 105 D<FF00FF001F001F001F001F00
-1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
-1F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210> 108
-D<FF07F007F000FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F
-001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
-001F001F001F001F001F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530> I<FF07E000
-FF1FF8001F307C001F403C001F803E001F803E001F003E001F003E001F003E001F003E00
-1F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00
-1F003E00FFE1FFC0FFE1FFC01A167E951F> I<00FE0007FFC00F83E01E00F03E00F87C00
-7C7C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00
-F81F01F00F83E007FFC000FE0017167E951C> I<FF0FE000FF3FF8001FE07C001F803E00
-1F001F001F001F801F001F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC0
-1F000FC01F000FC01F001F801F001F801F803F001FC03E001FE0FC001F3FF8001F0FC000
-1F0000001F0000001F0000001F0000001F0000001F0000001F0000001F000000FFE00000
-FFE000001A207E951F> I<0FF3003FFF00781F00600700E00300E00300F00300FC00007F
-E0007FF8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EF
-FC00C7F00011167E9516> 115 D<01800001800001800001800003800003800007800007
-80000F80003F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F
-80000F80000F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000
-F80011207F9F16> I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E
-001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E
-001F003E001F007E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F> I<FFE07FC0
-FFE07FC00F801C0007C0380003E0700003F0600001F8C00000F98000007F8000003F0000
-001F0000001F8000003FC0000037C0000063E00000C1F00001C0F8000380FC0007007E00
-0E003E00FF80FFE0FF80FFE01B167F951E> 120 D<FFE01FE0FFE01FE01F8007000F8006
-000FC00E0007C00C0007E00C0003E0180003E0180001F0300001F0300000F8600000F860
-00007CC000007CC000007FC000003F8000003F8000001F0000001F0000000E0000000E00
-00000C0000000C00000018000078180000FC380000FC300000FC60000069C000007F8000
-001F0000001B207F951E> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fj cmsy10 12 15
-/Fj 15 107 df<FFFFFFFCFFFFFFFC1E027C8C27> 0 D<03F0000FFC001FFE003FFF007F
-FF807FFF80FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC0FFFFC07FFF807FFF803F
-FF001FFE000FFC0003F00012147D9519> 15 D<000FFFFC007FFFFC01F0000003800000
-060000000C0000001800000030000000300000006000000060000000C0000000C0000000
-C0000000C0000000C0000000C0000000C0000000C0000000600000006000000030000000
-30000000180000000C000000060000000380000001E00000007FFFFC001FFFFC1E1E7C9A
-27> 26 D<00000001800000000001800000000001800000000001800000000000C00000
-000000C000000000006000000000003000000000003000000000001C00000000000E0000
-0000000700FFFFFFFFFFE0FFFFFFFFFFE0000000000700000000000E00000000001C0000
-000000300000000000300000000000600000000000C00000000000C00000000001800000
-00000180000000000180000000000180002B1A7D9832> 33 D<001FFF007FFF01E00003
-80000600000C0000180000300000300000600000600000600000C00000C00000FFFFFFFF
-FFFFC00000C000006000006000006000003000003000001800000C000006000003800001
-E000007FFF001FFF181E7C9A21> 50 D<00000300000300000600000600000C00000C00
-00180000180000300000300000600000600000C00000C00000C000018000018000030000
-0300000600000600000C00000C0000180000180000300000300000600000600000C00000
-C0000180000180000300000300000300000600000600000C00000C000018000018000030
-0000300000600000600000C00000400000183079A300> 54 D<C0C0C0C0C0C0C0C0E0E0
-C0C0C0C0C0C0C0C003127D9400> I<00008000018001F980070F000C0300180380180780
-3006C03006C0700CE0600C60600C60600C60E01870E01870E01870E03070E03070E03070
-E06070E06070E06070E06070E0C070E0C070E0C070E18070E180706180606300607300E0
-7300E03300C03600C01E01801E01800C03000F0E000DF800180000180000180000142A7E
-A519> 59 D<000100000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000000300000003000000030000000300000003
-000000030000000300000003000000030000FFFFFFFEFFFFFFFE1F207C9F27> 63
-D<40000040C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
-C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000
-C0C00000C0C00000C0C00000C0C00000C0C00000C0600001806000018030000300180006
-000E001C000780780001FFE000007F80001A1F7D9D21> 91 D<007F800001FFE0000780
-78000E001C0018000600300003006000018060000180C00000C0C00000C0C00000C0C000
-00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
-00C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C00000C0C000
-00C0400000401A1F7D9D21> I<000C0000000C0000001E0000001E0000001E0000003300
-0000330000006180000061800000C0C00000C0C00000C0C0000180600001806000030030
-00030030000300300006001800060018000C000C000C000C000C000C0018000600180006
-003000030030000300600001806000018060000180C00000C0C00000401A1F7D9D21> 94
-D<0003C0001E0000380000700000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00001C0000380000F00
-00F800000F000003800001C00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E000007000003800001E
-000003C012317DA419> 102 D<F800000F000003800001C00000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E000007000003800001E000003C0001E0000380000700000E00000E00000E00000E0
-0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00001C0000380000F0000F8000012317DA419> I<C0C0C0C0C0C0C0C0C0C0C0C0C0
-C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
-02317AA40E> 106 D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fk cmr12 12 65
-/Fk 65 125 df<001FC1F00070371800C03E3C01807C3C0380783C070038000700380007
-003800070038000700380007003800070038000700380007003800FFFFFFC00700380007
-003800070038000700380007003800070038000700380007003800070038000700380007
-0038000700380007003800070038000700380007003800070038000700380007003C007F
-E1FFC01E2380A21C> 11 D<001FC0000070200000C01000018038000380780007007800
-0700300007000000070000000700000007000000070000000700000007000000FFFFF800
-070078000700380007003800070038000700380007003800070038000700380007003800
-070038000700380007003800070038000700380007003800070038000700380007003800
-070038007FE1FF80192380A21B> I<001FD8000070380000C07800018078000380780007
-0038000700380007003800070038000700380007003800070038000700380007003800FF
-FFF800070038000700380007003800070038000700380007003800070038000700380007
-003800070038000700380007003800070038000700380007003800070038000700380007
-003800070038007FF3FF80192380A21B> I<000FC07F00007031C08000E00B004001801E
-00E003803E01E007003C01E007001C00C007001C000007001C000007001C000007001C00
-0007001C000007001C000007001C0000FFFFFFFFE007001C01E007001C00E007001C00E0
-07001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007
-001C00E007001C00E007001C00E007001C00E007001C00E007001C00E007001C00E00700
-1C00E007001C00E07FF1FFCFFE272380A229> I<70F8FCFC740404040408081010204006
-0F7CA20E> 39 D<00200040008001000300060004000C000C0018001800300030003000
-7000600060006000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
-6000600060007000300030003000180018000C000C000400060003000100008000400020
-0B327CA413> I<800040002000100018000C000400060006000300030001800180018001
-C000C000C000C000E000E000E000E000E000E000E000E000E000E000E000E000E000E000
-C000C000C001C0018001800180030003000600060004000C00180010002000400080000B
-327DA413> I<70F8FCFC7404040404080810102040060F7C840E> 44
-D<FFF8FFF80D02808B10> I<70F8F8F87005057C840E> I<01F000071C000C0600180300
-3803803803807001C07001C07001C07001C0F001E0F001E0F001E0F001E0F001E0F001E0
-F001E0F001E0F001E0F001E0F001E0F001E0F001E0F001E07001C07001C07001C07803C0
-3803803803801C07000C0600071C0001F00013227EA018> 48 D<008003800F80F38003
-800380038003800380038003800380038003800380038003800380038003800380038003
-800380038003800380038003800380038007C0FFFE0F217CA018> I<03F0000C1C001007
-002007804003C04003C08003E0F003E0F801E0F801E0F801E02003E00003E00003C00003
-C0000780000700000E00001C0000180000300000600000C0000180000100000200200400
-200800201800603000403FFFC07FFFC0FFFFC013217EA018> I<03F8000C1E00100F0020
-07804007C07807C07803C07807C03807C0000780000780000700000F00000C0000380003
-F000001C00000F000007800007800003C00003C00003E02003E07003E0F803E0F803E0F0
-03C04003C0400780200780100F000C1C0003F00013227EA018> I<000300000300000700
-000700000F00001700001700002700006700004700008700018700010700020700060700
-040700080700080700100700200700200700400700C00700FFFFF8000700000700000700
-000700000700000700000700000F80007FF015217FA018> I<70F8F8F870000000000000
-000000000070F8F8F87005157C940E> 58 D<FFFFFFFEFFFFFFFE000000000000000000
-0000000000000000000000000000000000000000000000FFFFFFFEFFFFFFFE1F0C7D9126
-> 61 D<07E01838201C400E800FF00FF00FF00F000F000E001C00380030006000C000C0
-00800080018001000100010001000100010000000000000000000000038007C007C007C0
-038010237DA217> 63 D<0001800000018000000180000003C0000003C0000003C00000
-05E0000005E0000009F0000008F0000008F00000107800001078000010780000203C0000
-203C0000203C0000401E0000401E0000C01F0000800F0000800F0001FFFF800100078001
-000780020003C0020003C0020003C0040001E0040001E0040001E0080000F01C0000F03E
-0001F8FF800FFF20237EA225> 65 D<FFFFF8000F800E0007800780078003C0078003E0
-078001E0078001F0078001F0078001F0078001F0078001F0078001E0078003E0078007C0
-07800F8007803E0007FFFE0007800780078003C0078001E0078001F0078000F0078000F8
-078000F8078000F8078000F8078000F8078000F8078001F0078001F0078003E0078007C0
-0F800F00FFFFFC001D227EA123> I<0007E0100038183000E0063001C00170038000F007
-0000F00E0000701E0000701C0000303C0000303C0000307C0000107800001078000010F8
-000000F8000000F8000000F8000000F8000000F8000000F8000000F80000007800000078
-0000107C0000103C0000103C0000101C0000201E0000200E000040070000400380008001
-C0010000E0020000381C000007E0001C247DA223> I<FFFFF0000F801E00078007000780
-0380078001C0078000E0078000F007800078078000780780007C0780003C0780003C0780
-003C0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780003E0780
-003E0780003C0780003C0780007C0780007807800078078000F0078000E0078001E00780
-03C0078007000F801E00FFFFF0001F227EA125> I<FFFFFFC00F8007C0078001C0078000
-C00780004007800040078000600780002007800020078000200780202007802000078020
-0007802000078060000780E00007FFE0000780E000078060000780200007802000078020
-000780200007800000078000000780000007800000078000000780000007800000078000
-00078000000FC00000FFFE00001B227EA120> 70 D<0007F008003C0C1800E0021801C0
-01B8038000F8070000780F0000381E0000381E0000183C0000183C0000187C0000087800
-000878000008F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
-1FFF780000F8780000787C0000783C0000783C0000781E0000781E0000780F0000780700
-0078038000B801C000B800E00318003C0C080007F00020247DA226> I<FFFC3FFF0FC003
-F0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
-E0078001E0078001E0078001E0078001E0078001E007FFFFE0078001E0078001E0078001
-E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001E0078001
-E0078001E0078001E0078001E00FC003F0FFFC3FFF20227EA125> I<FFFC0FC007800780
-078007800780078007800780078007800780078007800780078007800780078007800780
-07800780078007800780078007800780078007800FC0FFFC0E227EA112> I<FFFC00FF80
-0FC0007C0007800030000780002000078000400007800080000780010000078002000007
-80040000078008000007801000000780200000078040000007808000000781C000000783
-E000000785E000000788F000000790F0000007A078000007C03C000007803C000007801E
-000007800F000007800F00000780078000078007C000078003C000078001E000078001E0
-00078000F000078000F8000FC000FC00FFFC07FF8021227EA126> 75
-D<FFFC001F80000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00
-000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00010F00
-010F00010F00010F00030F00030F00020F00060F00060F001E1F007EFFFFFE18227DA11E
-> I<FF8007FF07C000F807C0007005E0002004F0002004F0002004780020047C0020043C
-0020041E0020041F0020040F002004078020040780200403C0200401E0200401E0200400
-F0200400F8200400782004003C2004003E2004001E2004000F2004000F20040007A00400
-03E0040003E0040001E0040001E0040000E00E0000601F000060FFE0002020227EA125>
-78 D<000FE00000783C0000E00E0003C00780078003C00F0001E00E0000E01E0000F03C
-0000783C0000787C00007C7C00007C7800003C7800003CF800003EF800003EF800003EF8
-00003EF800003EF800003EF800003EF800003EF800003E7800003C7C00007C7C00007C3C
-0000783E0000F81E0000F00F0001E00F0001E0078003C003C0078000E00E0000783C0000
-0FE0001F247DA226> I<FFFFF0000F803C0007800F0007800780078007C0078003C00780
-03E0078003E0078003E0078003E0078003E0078003E0078003C0078007C0078007800780
-0F0007803C0007FFF0000780000007800000078000000780000007800000078000000780
-0000078000000780000007800000078000000780000007800000078000000FC00000FFFC
-00001B227EA121> I<FFFFE000000F803C000007800E00000780078000078007C0000780
-03C000078003E000078003E000078003E000078003E000078003E000078003C000078007
-C000078007800007800E000007803C000007FFE000000780700000078038000007801C00
-0007801E000007800E000007800F000007800F000007800F000007800F000007800F8000
-07800F800007800F800007800F808007800FC080078007C0800FC003C100FFFC01E20000
-00007C0021237EA124> 82 D<03F0200C0C601802603001E07000E0600060E00060E000
-60E00020E00020E00020F00000F000007800007F00003FF0001FFE000FFF0003FF80003F
-C00007E00001E00000F00000F0000070800070800070800070800070C00060C00060E000
-C0F000C0C80180C6070081FC0014247DA21B> I<7FFFFFF8780780786007801840078008
-4007800840078008C007800C800780048007800480078004800780040007800000078000
-000780000007800000078000000780000007800000078000000780000007800000078000
-000780000007800000078000000780000007800000078000000780000007800000078000
-00078000000FC00001FFFE001E227EA123> I<FFF0007FC01F80001F000F00000C000F80
-000C000780000800078000080003C000100003C000100003C000100001E000200001E000
-200001F000600000F000400000F000400000780080000078008000007C008000003C0100
-00003C010000001E020000001E020000001E020000000F040000000F040000000F8C0000
-000788000000078800000003D000000003D000000003F000000001E000000001E0000000
-00C000000000C000000000C0000022237FA125> 86 D<FFF03FFC03FE1F8007E000F80F
-0003C000700F0003C000200F0001E00020078001E00040078001E00040078003F0004003
-C002F0008003C002F0008003C002F0008003E00478018001E00478010001E00478010001
-E0083C010000F0083C020000F0083C020000F0101E02000078101E04000078101E040000
-78200F0400003C200F0800003C200F0800003C600F8800001E40079000001E4007900000
-1E4007D000001F8003F000000F8003E000000F8003E000000F0001E00000070001C00000
-070001C00000060000C0000002000080002F237FA132> I<FEFEC0C0C0C0C0C0C0C0C0C0
-C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FE
-FE07317BA40E> 91 D<FEFE060606060606060606060606060606060606060606060606
-060606060606060606060606060606060606060606FEFE07317FA40E> 93
-D<1FE000303800780C00780E0030070000070000070000070000FF0007C7001E07003C07
-00780700700700F00708F00708F00708F00F087817083C23900FC1E015157E9418> 97
-D<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E1F000E61C00E80600F00300E00380E003C0E001C0E001E0E001E0E00
-1E0E001E0E001E0E001E0E001E0E001C0E003C0E00380F00700C80600C41C0083F001723
-7FA21B> I<01FE000703000C07801C0780380300780000700000F00000F00000F00000F0
-0000F00000F00000F000007000007800403800401C00800C010007060001F80012157E94
-16> I<0000E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E0
-0000E00000E00000E001F8E00704E00C02E01C01E03800E07800E07000E0F000E0F000E0
-F000E0F000E0F000E0F000E0F000E07000E07800E03800E01801E00C02E0070CF001F0FE
-17237EA21B> I<01FC000707000C03801C01C03801C07801E07000E0F000E0FFFFE0F000
-00F00000F00000F00000F000007000007800203800201C00400E008007030000FC001315
-7F9416> I<003E0000E30001C78003878003078007000007000007000007000007000007
-0000070000070000070000FFF80007000007000007000007000007000007000007000007
-00000700000700000700000700000700000700000700000700000700000700000780007F
-F000112380A20F> I<00007003F1980E1E181C0E18380700380700780780780780780780
-7807803807003807001C0E001E1C0033F0002000002000003000003800003FFE001FFFC0
-0FFFE03000F0600030C00018C00018C00018C000186000306000303800E00E038003FE00
-15217F9518> I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E00000E00000E1F800E60C00E80E00F00700F00700E00700E00700E00
-700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00
-70FFE7FF18237FA21B> I<1C003E003E003E001C00000000000000000000000000000000
-000E007E001E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E00FFC00A227FA10E> I<00E001F001F001F000E0000000000000000000000000
-00000000007007F000F00070007000700070007000700070007000700070007000700070
-00700070007000700070007000700070007000706070F0E0F0C061803F000C2C83A10F>
-I<0E0000FE00001E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
-000E00000E00000E03FC0E01F00E01C00E01800E02000E04000E08000E10000E38000EF8
-000F1C000E1E000E0E000E07000E07800E03C00E01C00E01E00E00F00E00F8FFE3FE1723
-7FA21A> I<0E00FE001E000E000E000E000E000E000E000E000E000E000E000E000E000E
-000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
-00FFE00B237FA20E> I<0E1FC07F00FE60E183801E807201C00F003C00E00F003C00E00E
-003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E00
-3800E00E003800E00E003800E00E003800E00E003800E00E003800E00E003800E00E0038
-00E0FFE3FF8FFE27157F942A> I<0E1F80FE60C01E80E00F00700F00700E00700E00700E
-00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E
-0070FFE7FF18157F941B> I<01FC000707000C01801800C03800E0700070700070F00078
-F00078F00078F00078F00078F00078F000787000707800F03800E01C01C00E0380070700
-01FC0015157F9418> I<0E1F00FE61C00E80600F00700E00380E003C0E003C0E001E0E00
-1E0E001E0E001E0E001E0E001E0E001E0E003C0E003C0E00380F00700E80E00E41C00E3F
-000E00000E00000E00000E00000E00000E00000E00000E00000E0000FFE000171F7F941B
-> I<01F8200704600E02601C01603801E07800E07800E0F000E0F000E0F000E0F000E0F0
-00E0F000E0F000E07800E07800E03801E01C01E00C02E0070CE001F0E00000E00000E000
-00E00000E00000E00000E00000E00000E00000E0000FFE171F7E941A> I<0E3CFE461E8F
-0F0F0F060F000E000E000E000E000E000E000E000E000E000E000E000E000E000F00FFF0
-10157F9413> I<0F8830786018C018C008C008E008F0007F003FE00FF001F8003C801C80
-0C800CC00CC008E018D0308FC00E157E9413> I<02000200020002000600060006000E00
-1E003E00FFFC0E000E000E000E000E000E000E000E000E000E000E000E040E040E040E04
-0E040E040708030801F00E1F7F9E13> I<0E0070FE07F01E00F00E00700E00700E00700E
-00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00F00E00F006
-017003827800FC7F18157F941B> I<FF80FE1E00781E00300E00200E0020070040070040
-0780C003808003808001C10001C10000E20000E20000E200007400007400003800003800
-00380000100017157F941A> I<FF8FF87F3E01E03C1C01C0181C01E0180E01E0100E0260
-100E027010070270200704302007043820038438400388184003881C4001C81C8001D00C
-8001D00E8000F00F0000E0070000E00700006006000040020020157F9423> I<FF83FE1F
-00F00E00C007008007810003830001C20000E400007800007800003800003C00004E0000
-8F000187000103800201C00401E00C00E03E01F0FF03FE17157F941A> I<FF80FE1E0078
-1E00300E00200E00200700400700400780C003808003808001C10001C10000E20000E200
-00E200007400007400003800003800003800001000001000002000002000002000004000
-F04000F08000F180004300003C0000171F7F941A> I<3FFFC0380380300780200700600E
-00401C00403C0040380000700000E00001E00001C0000380400700400F00400E00C01C00
-80380080780180700780FFFF8012157F9416> I<FFFFFFFFFFFF3001808C31> 124
-D E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fl cmbx12 14.4 19
-/Fl 19 118 df<00007FE0030007FFFC07001FFFFF0F007FF00F9F00FF0001FF01FC0000
-FF03F800007F07F000003F0FE000001F1FC000001F1FC000000F3F8000000F3F80000007
-7F800000077F800000077F00000000FF00000000FF00000000FF00000000FF00000000FF
-00000000FF00000000FF00000000FF00000000FF000000007F000000007F800000007F80
-0000073F800000073F800000071FC00000071FC000000E0FE000000E07F000001C03F800
-003C01FC00007800FF0001F0007FF007C0001FFFFF800007FFFE0000007FF00028297CA8
-31> 67 D<FFFFFC0000FFFFFC0000FFFFFC000003FC00000003FC00000003FC00000003
-FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC
-00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00000003FC00
-000003FC00000003FC00000003FC00000003FC0001C003FC0001C003FC0001C003FC0001
-C003FC0003C003FC00038003FC00038003FC00078003FC00078003FC000F8003FC000F80
-03FC001F8003FC007F8003FC01FF00FFFFFFFF00FFFFFFFF00FFFFFFFF0022297EA828>
-76 D<0000FFC00000000FFFFC0000003F807F000000FE001FC00001F80007E00003F000
-03F00007E00001F8000FE00001FC001FC00000FE001FC00000FE003F8000007F003F8000
-007F007F8000007F807F0000003F807F0000003F807F0000003F80FF0000003FC0FF0000
-003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000003FC0FF0000
-003FC0FF0000003FC0FF0000003FC07F0000003F807F8000007F807F8000007F803F8000
-007F003F8000007F001FC00000FE001FC00000FE000FE00001FC0007F00003F80003F800
-07F00001FC000FE00000FE001FC000003FC0FF0000000FFFFC00000000FFC000002A297C
-A833> 79 D<FFFFF0007FFFFFFFF0007FFFFFFFF0007FFF03FE000001C001FE00000380
-01FE0000038001FF0000078000FF0000070000FF80000F00007F80000E00007FC0000E00
-003FC0001C00003FC0001C00003FE0003C00001FE0003800001FF0007800000FF0007000
-000FF80070000007F800E0000007F800E0000003FC01C0000003FC01C0000003FE03C000
-0001FE0380000001FF0780000000FF0700000000FF87000000007F8E000000007F8E0000
-00007FDE000000003FDC000000003FFC000000001FF8000000001FF8000000000FF00000
-00000FF0000000000FF00000000007E00000000007E00000000003C00000000003C00000
-30297FA833> 86 D<03FF80000FFFF0001F01FC003F80FE003F807F003F803F003F803F
-801F003F8000003F8000003F8000003F8000003F80003FFF8001FC3F800FE03F801F803F
-803F003F807E003F80FC003F80FC003F80FC003F80FC003F80FC005F807E00DF803F839F
-FC1FFE0FFC03FC03FC1E1B7E9A21> 97 D<FFE00000FFE00000FFE000000FE000000FE0
-00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE0
-00000FE000000FE1FE000FEFFF800FFE07E00FF803F00FF001F80FE000FC0FE000FC0FE0
-007E0FE0007E0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0
-007F0FE0007E0FE0007E0FE0007E0FE000FC0FE000FC0FF001F80FF803F00F9C0FE00F0F
-FF800E01FC00202A7EA925> I<00007FF000007FF000007FF0000007F0000007F0000007
-F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007
-F0003F87F001FFF7F007F03FF00FC00FF01F8007F03F0007F03F0007F07E0007F07E0007
-F07E0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007
-F07E0007F07E0007F03F0007F03F0007F01F800FF00FC01FF007E07FFF01FFE7FF007F87
-FF202A7EA925> 100 D<003FC00001FFF00003E07C000F803E001F801F001F001F003F00
-0F807E000F807E000FC07E000FC0FE0007C0FE0007C0FFFFFFC0FFFFFFC0FE000000FE00
-0000FE0000007E0000007E0000007F0000003F0001C01F0001C00F80038007C0070003F0
-1E0000FFFC00003FE0001A1B7E9A1F> I<0007F8003FFC007E3E01FC7F03F87F03F07F07
-F07F07F03E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007
-F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007
-F00007F00007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF8018
-2A7EA915> I<FFE00000FFE00000FFE000000FE000000FE000000FE000000FE000000FE0
-00000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE07E000FE1
-FF800FE30FC00FE40FE00FE807E00FF807F00FF007F00FF007F00FE007F00FE007F00FE0
-07F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE0
-07F00FE007F00FE007F00FE007F00FE007F0FFFE3FFFFFFE3FFFFFFE3FFF202A7DA925>
-104 D<07000F801FC03FE03FE03FE01FC00F8007000000000000000000000000000000FF
-E0FFE0FFE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F
-E00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F2B7EAA12> I<FFE0FFE0FFE00FE00FE00FE0
-0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0
-0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE
-0F2A7EA912> 108 D<FFC07E00FFC1FF80FFC30FC00FC40FE00FC807E00FD807F00FD007
-F00FD007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007
-F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F0FFFE3F
-FFFFFE3FFFFFFE3FFF201B7D9A25> 110 D<003FE00001FFFC0003F07E000FC01F801F80
-0FC03F0007E03F0007E07E0003F07E0003F07E0003F0FE0003F8FE0003F8FE0003F8FE00
-03F8FE0003F8FE0003F8FE0003F8FE0003F87E0003F07E0003F03F0007E03F0007E01F80
-0FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22> I<FFE1FE00FFEFFF80FFFE0F
-E00FF803F00FF001F80FE001FC0FE000FC0FE000FE0FE000FE0FE0007F0FE0007F0FE000
-7F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007F0FE0007E0FE000FE0FE000FE0FE000
-FC0FE001FC0FF001F80FF807F00FFC0FE00FEFFF800FE1FC000FE000000FE000000FE000
-000FE000000FE000000FE000000FE000000FE000000FE00000FFFE0000FFFE0000FFFE00
-0020277E9A25> I<FFC1F0FFC7FCFFC63E0FCC7F0FD87F0FD07F0FD07F0FF03E0FE0000F
-E0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000F
-E0000FE0000FE000FFFF00FFFF00FFFF00181B7F9A1B> 114 D<03FE300FFFF03E03F078
-00F07000F0F00070F00070F80070FE0000FFE0007FFF007FFFC03FFFE01FFFF007FFF800
-FFF80007FC0000FCE0007CE0003CF0003CF00038F80038FC0070FF01E0E7FFC0C1FF0016
-1B7E9A1B> I<00E00000E00000E00000E00001E00001E00001E00003E00003E00007E000
-0FE0001FFFE0FFFFE0FFFFE00FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000
-0FE0000FE0000FE0000FE0000FE0000FE0700FE0700FE0700FE0700FE0700FE0700FE070
-07F0E003F0C001FF80007F0014267FA51A> I<FFE07FF0FFE07FF0FFE07FF00FE007F00F
-E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00F
-E007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE007F00FE00FF00F
-E00FF007E017F003F067FF01FFC7FF007F87FF201B7D9A25> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fm cmr12 14.4 20
-/Fm 20 118 df<78FCFCFEFE7A02020202040404080810204007127B8510> 44
-D<00200000E00001E0000FE000FFE000F1E00001E00001E00001E00001E00001E00001E0
-0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
-0001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E00001E0
-0001E00003F000FFFFC0FFFFC012287BA71D> 49 D<01FC0007FF000C0FC01803E02001
-F06001F04000F84000F8F800FCFC00FCFC007CFC007CFC007C7800FC0000FC0000F80000
-F80001F00001F00003E00003C0000780000700000E00001C0000380000300000600000C0
-000180000300040200040400080800081000082000183FFFF87FFFF0FFFFF0FFFFF01628
-7DA71D> I<000FC0003FF000F01801C01803803C07007C0F007C0E00381E00003C00003C
-00003C0000780000780000780000F83F00F8C1C0F900E0FA0070FA0038FC003CFC001EFC
-001EF8001EF8001FF8001FF8001FF8001F78001F78001F78001F78001F3C001E3C001E1C
-003C1E003C0E007807007003C1E001FFC0007E0018297EA71D> 54
-D<007E0001FF800781C00F00E01E00703C00383C003878003C78003CF8001EF8001EF800
-1EF8001EF8001FF8001FF8001FF8001F78001F78003F78003F3C003F1C005F0E005F0700
-9F03831F00FC1F00001E00001E00001E00003E00003C00003C0000381C00783E00703E00
-E03C01C01803801C0F000FFE0003F80018297EA71D> 57 D<0000FF00100007FFE03000
-1FC07830003E000C7000F80006F001F00003F003E00001F007C00000F00F800000700F80
-0000701F000000303F000000303E000000303E000000107E000000107E000000107C0000
-0000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000000
-00FC00000000FC0000FFFF7C0000FFFF7E000003F07E000001F03E000001F03E000001F0
-3F000001F01F000001F00F800001F00F800001F007C00001F003E00001F001F00002F000
-F80002F0003E000C70001FC038300007FFE0100000FF8000282B7DA92E> 71
-D<01FFFE01FFFE0007E00003E00003E00003E00003E00003E00003E00003E00003E00003
-E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
-E00003E00003E00003E00003E00003E00003E00003E03003E07803E0FC03E0FC03E0FC03
-C0F807C0400780200F00300E000C3C0003F000172A7DA81E> 74
-D<0001FF0000000F01E000003C0078000078003C0000E0000E0001E0000F0003C0000780
-07800003C00F800003E01F000001F01F000001F03E000000F83E000000F87E000000FC7E
-000000FC7C0000007C7C0000007CFC0000007EFC0000007EFC0000007EFC0000007EFC00
-00007EFC0000007EFC0000007EFC0000007EFC0000007E7C0000007C7E000000FC7E0000
-00FC7E000000FC3E000000F83F000001F81F000001F01F000001F00F800003E007800003
-C007C00007C003E0000F8000F0001E000078003C00003C007800000F01E0000001FF0000
-272B7DA92E> 79 D<03FC00000C070000100380003C01C0003E01E0003E00F0001C00F0
-000800F0000000F0000000F0000000F000007FF00003E0F0000F80F0001E00F0003C00F0
-007C00F0007800F040F800F040F800F040F800F040F801F0407C01F0403C0278801E0C7F
-8007F01E001A1A7E991D> 97 D<0F000000FF000000FF0000001F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
-00000F0000000F07E0000F1838000F600E000F8007000F8007800F0003C00F0003C00F00
-01E00F0001E00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F0001F00F00
-01E00F0001E00F0003E00F0003C00F0003800F8007800E800F000E401C000C303800080F
-C0001C2A7EA921> I<007F0001C0E00700100E00781E00F83C00F83C00707C0020780000
-F80000F80000F80000F80000F80000F80000F80000F800007800007C00003C00083C0008
-1E00100E002007006001C180007E00151A7E991A> I<00FC000387800701C00E01E01C00
-E03C00F03C00F0780078780078F80078F80078FFFFF8F80000F80000F80000F80000F800
-007800007800003C00083C00081E00100E002007004001C180007E00151A7E991A> 101
-D<00000F0001FC3080070743800E03C3801E03C1003C01E0003C01E0007C01F0007C01F0
-007C01F0007C01F0007C01F0003C01E0003C01E0001E03C0000E0380001707000011FC00
-0030000000300000003000000030000000180000001FFF80000FFFF00007FFF80018007C
-0030001E0070000E0060000700E0000700E0000700E0000700E000070070000E0070000E
-0038001C001C0038000781E00000FF000019287E9A1D> 103 D<1E003F003F003F003F00
-1E000000000000000000000000000000000000000F00FF00FF001F000F000F000F000F00
-0F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F00FFF0FFF0
-0C297EA811> 105 D<007E0003C3C00700E00E00701C00383C003C3C003C78001E78001E
-F8001FF8001FF8001FF8001FF8001FF8001FF8001FF8001F78001E78001E3C003C3C003C
-1C00380E00700700E003C3C0007E00181A7E991D> 111 D<003F010001E0830003804300
-0F0027001E0017001E001F003C000F007C000F007C000F0078000F00F8000F00F8000F00
-F8000F00F8000F00F8000F00F8000F00F8000F007C000F007C000F003C000F003E001F00
-1E001F000F002F0007804F0001C18F00007E0F0000000F0000000F0000000F0000000F00
-00000F0000000F0000000F0000000F0000000F0000000F000000FFF00000FFF01C267E99
-1F> 113 D<0F0F80FF11C0FF23E01F43E00F83E00F81C00F80000F00000F00000F00000F
-00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F00000F
-00000F8000FFFC00FFFC00131A7E9917> I<07F0801C0D80300380600180E00180E00080
-E00080F00080F800007E00007FE0003FFC001FFE0007FF00003F800007808003C08003C0
-8001C0C001C0C001C0E00180E00380F00300CC0E0083F800121A7E9917> I<0080000080
-000080000080000180000180000180000380000380000780000F80001FFF80FFFF800780
-000780000780000780000780000780000780000780000780000780000780000780000780
-0007804007804007804007804007804007804007804003C08001C08000E100003E001225
-7FA417> I<0F000F00FF00FF00FF00FF001F001F000F000F000F000F000F000F000F000F
-000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F000F
-000F000F000F000F000F000F000F001F000F001F0007002F0003804F8001C08FF0007F0F
-F01C1A7E9921> I E
-%EndDVIPSBitmapFont
-%DVIPSBitmapFont: Fn cmr17 20.74 18
-/Fn 18 119 df<000001FF00008000001FFFE0018000007F007801800001F8000E038000
-03E000070780000FC000018780001F000000CF80003E0000006F80007C0000003F8000F8
-0000003F8001F00000001F8003F00000000F8007E00000000F8007C000000007800FC000
-000007800FC000000007801F8000000003801F8000000003803F8000000003803F000000
-0001803F0000000001807F0000000001807F0000000001807E0000000000007E00000000
-0000FE000000000000FE000000000000FE000000000000FE000000000000FE0000000000
-00FE000000000000FE000000000000FE000000000000FE000000000000FE000000000000
-FE0000000000007E0000000000007E0000000000007F0000000000007F0000000001803F
-0000000001803F0000000001803F8000000001801F8000000001801F8000000003000FC0
-00000003000FC0000000030007E0000000060007E0000000060003F0000000060001F000
-00000C0000F80000001800007C0000001800003E0000003000001F0000006000000FC000
-01C0000003E0000380000001F8000E000000007F007C000000001FFFF00000000001FF00
-0000313D7CBB39> 67 D<FFFFFC000000FFFFFC00000003FE0000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000000001F80000000001F80000000001
-F80000000001F80000000001F80000000001F80000006001F80000006001F80000006001
-F80000006001F80000006001F8000000E001F8000000C001F8000000C001F8000000C001
-F8000000C001F8000001C001F8000001C001F8000001C001F8000003C001F8000007C001
-F8000007C001F800000FC001F800003F8001F80000FF8003FC0007FF80FFFFFFFFFF80FF
-FFFFFFFF802B3B7CBA32> 76 D<000003FF00000000001E01E000000000F0003C000000
-03C0000F000000078000078000000F000003C000003E000001F000007C000000F80000F8
-0000007C0001F00000003E0001F00000003E0003E00000001F0007E00000001F8007C000
-00000F800FC00000000FC00F8000000007C01F8000000007E01F8000000007E03F000000
-0003F03F0000000003F03F0000000003F07F0000000003F87E0000000001F87E00000000
-01F87E0000000001F8FE0000000001FCFE0000000001FCFE0000000001FCFE0000000001
-FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FCFE0000000001FC
-FE0000000001FCFE0000000001FC7E0000000001F87F0000000003F87F0000000003F87F
-0000000003F87F0000000003F83F0000000003F03F8000000007F01F8000000007E01F80
-00000007E01FC00000000FE00FC00000000FC007C00000000F8007E00000001F8003E000
-00001F0001F00000003E0001F80000007E0000F80000007C00007C000000F800003E0000
-01F000000F000003C000000780000780000003E0001F00000000F8007C000000001E01E0
-0000000003FF000000363D7CBB3E> 79 D<003F80000001C0F0000003003C000004001E
-00000C000F000018000780001C0007C0003E0003C0003F0003E0003F0003E0003F0003E0
-001E0003E000000003E000000003E000000003E00000003FE000000FF3E000007E03E000
-01F803E00003E003E0000FC003E0001F8003E0003F0003E0003E0003E0007E0003E0007E
-0003E060FC0003E060FC0003E060FC0003E060FC0007E060FC0007E0607C000BE0607E00
-0BE0603E0011F0C01F0060F0C007C1807F8000FE003E0023257CA427> 97
-D<03E0000000FFE0000000FFE000000007E000000003E000000003E000000003E0000000
-03E000000003E000000003E000000003E000000003E000000003E000000003E000000003
-E000000003E000000003E000000003E000000003E000000003E000000003E000000003E0
-00000003E000000003E03FC00003E0E0780003E3001C0003E6000F0003E800078003F800
-03C003F00001E003E00001F003E00000F003E00000F803E00000F803E00000FC03E00000
-7C03E000007C03E000007E03E000007E03E000007E03E000007E03E000007E03E000007E
-03E000007E03E000007E03E000007E03E000007C03E000007C03E00000FC03E00000F803
-E00000F803E00001F003E00001E003F00003E003D80003C003C80007800384000E000383
-001C000381C0F00003003F8000273C7EBB2C> I<0007F800003C0E0000F0018001E000C0
-03C00060078000300F0000701F0000F81F0001F83E0001F83E0001F87E0000F07C000000
-7C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000
-FC0000007C0000007C0000007E0000003E0000003E00000C1F00000C1F0000180F800018
-0780003003C0006001E000C000F00180003C0E000007F8001E257DA423> I<0007F80000
-3C1E0000F0078001C003C003C001E0078000F00F0000F81F0000781E00007C3E00007C3E
-00007C7E00003E7C00003E7C00003EFC00003EFC00003EFFFFFFFEFC000000FC000000FC
-000000FC000000FC000000FC0000007C0000007C0000007E0000003E0000003E0000061F
-0000060F00000C0F80000C0780001803C0003000E00060007000C0001E07000003FC001F
-257EA423> 101 D<0000FC0000078300000E0380001C07C0003C0FC000780FC000F80FC0
-00F8078000F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F00000FFFFFC00FFFFFC00
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000003F800007FFFE0007FFFE0001A3C7FBB
-18> I<07000F801FC01FC01FC00F80070000000000000000000000000000000000000000
-0000000000000007C0FFC0FFC00FC007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C00FE0FFFEFFFE0F397DB815> 105 D<0003800007C0000FE0000FE0000FE00007C0
-000380000000000000000000000000000000000000000000000000000000000000000000
-0000000000000007E000FFE000FFE0000FE00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E0
-7803C0FC07C0FC0780FC0780FC0F00780E00381C000FE000134A82B818> I<07C0FFC0FF
-C00FC007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007C007
-C00FE0FFFEFFFE0F3C7DBB15> 108 D<03E01FE0003FC000FFE0607C00C0F800FFE0801E
-01003C0007E3000F06001E0003E4000F88001F0003E4000F88001F0003E8000790000F00
-03E80007D0000F8003F00007E0000F8003F00007E0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-03E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007
-C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F8003E00007C0000F80
-07F0000FE0001FC0FFFF81FFFF03FFFEFFFF81FFFF03FFFE3F257EA443> I<03E01FE000
-FFE0607C00FFE0801E0007E3000F0003E4000F8003E4000F8003E800078003E80007C003
-F00007C003F00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E0
-0007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E000
-07C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007C003E00007
-C003E00007C003E00007C003E00007C003E00007C007F0000FE0FFFF81FFFFFFFF81FFFF
-28257EA42C> I<0007FC0000001C070000007001C00001E000F00003C00078000780003C
-000F00001E001F00001F001E00000F003E00000F803E00000F807C000007C07C000007C0
-7C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC
-000007E0FC000007E0FC000007E07C000007C07C000007C07E00000FC03E00000F803E00
-000F801E00000F001F00001F000F00001E000780003C0003C000780001E000F000007001
-C000001C0700000007FC000023257EA427> I<03E03E00FFE0C300FFE1078007E20FC003
-E40FC003E80FC003E8078003E8030003F0000003F0000003F0000003E0000003E0000003
-E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
-E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003E0000003
-E0000003E0000003E0000007F00000FFFFC000FFFFC0001A257EA41E> 114
-D<00FF02000700C6000C002E0010001E0030001E0060000E0060000E00E0000600E00006
-00E0000600F0000600F8000600FC0000007F0000003FF000003FFF80000FFFE00007FFF0
-0001FFFC00003FFE000001FE0000003F00C0001F00C0000F80C0000780E0000380E00003
-80E0000380E0000380F0000300F0000300F8000700F8000600E4000C00E2001800C18070
-00807F800019257DA41F> I<003000000030000000300000003000000030000000300000
-0070000000700000007000000070000000F0000000F0000001F0000001F0000003F00000
-07F000001FFFFE00FFFFFE0001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F00000
-01F0000001F0000001F0000001F0000001F0018001F0018001F0018001F0018001F00180
-01F0018001F0018001F0018001F0018000F0010000F8030000F8030000780200003C0400
-000E08000003F00019357FB41E> I<FFFE000FFFFFFE000FFF07F00007F803E00003E003
-E00001C001F00001C001F000018001F800018000F800030000F8000300007C000600007C
-000600007E000600003E000C00003E000C00003F001C00001F001800001F001800000F80
-3000000F803000000FC070000007C060000007C060000003E0C0000003E0C0000003F1C0
-000001F180000001F180000000FB00000000FB00000000FF000000007E000000007E0000
-00003C000000003C000000003C0000000018000028257FA42A> 118
-D E
-%EndDVIPSBitmapFont
-end
-%%EndProlog
-%%BeginSetup
-%%Feature: *Resolution 300dpi
-TeXDict begin
-%%PaperSize: a4
-
-userdict/PStoPSxform PStoPSmatrix matrix currentmatrix
- matrix invertmatrix matrix concatmatrix
- matrix invertmatrix put
-%%EndSetup
-%%Page: (0,1) 1
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 0.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-/showpage{}def/copypage{}def/erasepage{}def
-PStoPSxform concat
-1 0 bop Fn 281 370 a(Cleaner) p 570 370 a(seman) n(tics) p
-927 370 a(for) p 1047 370 a(Ob) t(jectiv) n(e) p 1404
-370 a(Lab) r(el) p Fm 717 518 a(Jacques) p 934 518 a(Garrigue) 719
-634 y(Octob) r(er) p 945 634 a(26,) p 1040 634 a(1999) p
-Fl 11 836 a(Credits) p Fk 11 929 a(This) p 122 929 a(prop) q(osal) p
-319 929 a(con) o(tains) p 510 929 a(ideas) p 632 929
-a(from) p 747 929 a(Damien) p 928 929 a(Doligez) p 1101
-929 a(and) p 1196 929 a(Pierre) p 1340 929 a(W) l(eis.) p
-Fl 11 1073 a(Lab) r(els) p 221 1073 a(and) p 351 1073
-a(optionals) p Fk 11 1165 a(Lab) q(els) p 165 1165 a(and) p
-259 1165 a(optional) p 449 1165 a(argumen) o(ts) p 687
-1165 a(had) p 781 1165 a(t) o(w) o(o) p 873 1165 a(problems) p
-1082 1165 a(in) p 1139 1165 a(Ob) s(jectiv) o(e) p 1360
-1165 a(Lab) q(el.) p Fj 83 1280 a(\017) p Fk 133 1280
-a(They) p 259 1280 a(w) o(ere) p 372 1280 a(not) p 459
-1280 a(fully) p 570 1280 a(coheren) o(t) p 767 1280 a(with) p
-878 1280 a(the) p 963 1280 a(original) p 1139 1280 a(call-b) o(y-v) m
-(alue) p 1423 1280 a(seman) o(tics) p 1644 1280 a(of) p
-1700 1280 a(the) p 1784 1280 a(lan-) 133 1340 y(guage.) p
-303 1340 a(In) p 368 1340 a(some) p 495 1340 a(\(subtle\)) p
-681 1340 a(cases,) p 823 1340 a(a) p 868 1340 a(side-e\013ect) p
-1099 1340 a(migh) o(t) p 1243 1340 a(get) p 1329 1340
-a(dela) o(y) o(ed) p 1508 1340 a(more) p 1635 1340 a(than) p
-1753 1340 a(in) p 1814 1340 a(an) 133 1400 y(un) o(t) o(yp) q(ed) p
-322 1400 a(seman) o(tics.) p Fj 83 1502 a(\017) p Fk
-133 1502 a(F) l(or) p 220 1502 a(optional) p 410 1502
-a(argumen) o(ts,) p 660 1502 a(no) p 728 1502 a(un) o(t) o(yp) q(ed) p
-918 1502 a(seman) o(tics) p 1139 1502 a(existed.) 84
-1616 y(This) p 195 1616 a(new) p 295 1616 a(prop) q(osal) p
-492 1616 a(corrects) p 674 1616 a(these) p 799 1616 a(t) o(w) o(o) p
-891 1616 a(\015a) o(ws.) p Fi 11 1746 a(Syn) n(tax) p
-Fk 11 1838 a(W) l(e) p 95 1838 a(k) o(eep) p 206 1838
-a(Ob) s(jectiv) o(e) p 426 1838 a(Lab) q(el's) p 594
-1838 a(syn) o(tax,) p 764 1838 a(except) p 917 1838 a(for) p
-991 1838 a(default) p 1155 1838 a(v) m(alues) p 1301
-1838 a(in) p 1357 1838 a(optional) p 1547 1838 a(argumen) o(ts.) p
-Fh 329 1944 a(typ) n(expr) p Fk 528 1944 a(::=) p Fg
-634 1944 a(:) p 656 1944 a(:) p 678 1944 a(:) p Fj 579
-2004 a(j) p Fh 634 2004 a(typ) n(expr) p Fj 806 2004
-a(!) p Fh 870 2004 a(typ) n(expr) p Fj 579 2064 a(j) p
-Fk 634 2064 a([?]) p Fi(lab) r(el) p Fk 801 2064 a(:) p
-Fh(typ) n(expr) p Fj 987 2064 a(!) p Fh 1050 2064 a(typ) n(expr) 391
-2124 y(expr) p Fk 528 2124 a(::=) p Fg 634 2124 a(:) p
-656 2124 a(:) p 678 2124 a(:) p Fj 579 2185 a(j) p Fh
-634 2185 a(expr) p 746 2185 a(lab) n(ele) n(d-expr) p
-Ff 991 2163 a(+) p Fj 579 2245 a(j) p Fe 634 2245 a(fun) p
-Fj 728 2245 a(f) p Fh(lab) n(ele) n(d-simple-p) n(attern) p
-Fj 1209 2245 a(g) p Ff 1234 2227 a(+) p Fk 1280 2245
-a([) p Fe(when) p Fh 1412 2245 a(expr) p Fk 1507 2245
-a(]) p Fj 1535 2245 a(!) p Fh 1599 2245 a(expr) p Fj
-579 2305 a(j) p Fe 634 2305 a(function) p Fh 856 2305
-a(lab) n(ele) n(d-p) n(attern) p Fk 1177 2305 a([) p
-Fe(when) p Fh 1309 2305 a(expr) p Fk 1404 2305 a(]) p
-Fj 1432 2305 a(!) p Fh 1496 2305 a(expr) p Fj 785 2365
-a(f) p Fe(|) p Fh 851 2365 a(lab) n(ele) n(d-p) n(attern) p
-Fk 1172 2365 a([) p Fe(when) p Fg 1305 2365 a(expr) p
-Fk 1403 2365 a(]) p Fj 1430 2365 a(!) p Fh 1494 2365
-a(expr) p Fj 1589 2365 a(g) p Fd 1614 2347 a(\003) p
-Fh 242 2425 a(lab) n(ele) n(d-expr) p Fk 528 2425 a(::=) p
-634 2425 a([?]) p Fh(expr) p Fj 579 2486 a(j) p Fk 634
-2486 a([?]) p Fi(lab) r(el) p Fk 801 2486 a(:) p Fh(expr) 182
-2546 y(lab) n(ele) n(d-p) n(attern) p Fk 528 2546 a(::=) p
-Fh 634 2546 a(p) n(attern) p Fj 579 2606 a(j) p Fi 634
-2606 a(lab) r(el) p Fk 751 2606 a(:) p Fh(p) n(attern) p
-Fj 579 2666 a(j) p Fk 634 2666 a(?[) p Fe(\() p Fh(expr) p
-Fe(\)) p Fk(]) p Fi(lab) r(el) p Fk 943 2666 a(:) p Fh
-956 2666 a(p) n(attern) p Fk 926 2937 a(1) p eop
-PStoPSsaved restore
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 421.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-PStoPSxform concat
-2 1 bop Fi 11 168 a(Dynamic) p 247 168 a(seman) n(tics) p
-Fj 11 261 a(;) p Fk 52 261 a(is) p 101 261 a(a) p 141
-261 a(notation) p 337 261 a(for) p 411 261 a(the) p 495
-261 a(empt) o(y) p 644 261 a(lab) q(el.) 86 366 y(\() p
-Fe(fun) p Fi 198 366 a(l) p Fc 214 373 a(i) p Fk 227
-366 a(:) p Fg(x) p Fj 282 366 a(!) p Fg 346 366 a(e) p
-Fk(\)) p Fi 404 366 a(l) p Fc 420 373 a(1) p Fk 442 366
-a(:) p Fg 455 366 a(e) p Ff 478 373 a(1) p Fg 506 366
-a(:) p 528 366 a(:) p 550 366 a(:) p Fi 571 366 a(l) p
-Fc 587 373 a(n) p Fk 612 366 a(:) p Fg 625 366 a(e) p
-Fb 648 373 a(n) p Fj 515 427 a(!) p Fk 579 427 a(\() p
-Fg(e) p Fk([) p Fg(e) p Fb 658 434 a(i) p Fg 671 427
-a(=x) p Fk(]) p Fi 752 427 a(l) p Fc 768 434 a(1) p Fk
-790 427 a(:) p Fg(e) p Ff 827 434 a(1) p Fg 855 427 a(:) p
-877 427 a(:) p 899 427 a(:) p Fi 920 427 a(l) p Fc 936
-434 a(i) p Fd(\000) p Fc(1) p Fk 997 427 a(:) p Fg 1010
-427 a(e) p Fb 1033 434 a(i) p Fd(\000) p Ff(1) p Fi 1108
-427 a(l) p Fc 1124 434 a(i) p Ff(+) p Fc(1) p Fk 1185
-427 a(:) p Fg(e) p Fb 1222 434 a(i) p Ff(+1) p Fg 1289
-427 a(:) p 1311 427 a(:) p 1333 427 a(:) p Fi 1354 427
-a(l) p Fc 1370 434 a(n) p Fk 1395 427 a(:) p Fg 1408
-427 a(e) p Fb 1431 434 a(n) p Fk 86 487 a(\() p Fe(fun) p
-Fk 198 487 a(?) p Fi(l) p Fc 237 494 a(i) p Fk 250 487
-a(:) p Fg(x) p Fj 305 487 a(!) p Fg 369 487 a(e) p Fk(\)) p
-Fi 427 487 a(l) p Fc 443 494 a(1) p Fk 465 487 a(:) p
-Fg 478 487 a(e) p Ff 501 494 a(1) p Fg 529 487 a(:) p
-551 487 a(:) p 573 487 a(:) p Fi 594 487 a(l) p Fc 610
-494 a(n) p Fk 635 487 a(:) p Fg 648 487 a(e) p Fb 671
-494 a(n) p Fj 515 547 a(!) p Fg 579 547 a(e) p Fk([) p
-Fe(Some) p Fk 717 547 a(\() p Fg(e) p Fb 759 554 a(i) p
-Fk 773 547 a(\)) p Fg(=x) p Fk(]) p Fi 874 547 a(l) p
-Fc 890 554 a(1) p Fk 912 547 a(:) p Fg 925 547 a(e) p
-Ff 948 554 a(1) p Fg 976 547 a(:) p 998 547 a(:) p 1020
-547 a(:) p Fi 1042 547 a(l) p Fc 1058 554 a(i) p Fd(\000) p
-Fc(1) p Fk 1118 547 a(:) p Fg(e) p Fb 1155 554 a(i) p
-Fd(\000) p Ff(1) p Fi 1230 547 a(l) p Fc 1246 554 a(i) p
-Ff(+) p Fc(1) p Fk 1307 547 a(:) p Fg 1320 547 a(e) p
-Fb 1343 554 a(i) p Ff(+1) p Fg 1410 547 a(:) p 1432 547
-a(:) p 1454 547 a(:) p Fi 1476 547 a(l) p Fc 1492 554
-a(n) p Fk 1516 547 a(:) p Fg(e) p Fb 1553 554 a(n) p
-Fk 86 607 a(\() p Fe(fun) p Fk 198 607 a(?) p Fi(l) p
-Fk(:) p Fg 250 607 a(x) p Fj 292 607 a(!) p Fg 356 607
-a(e) p Fk(\)) p Fi 413 607 a(l) p Fc 429 614 a(1) p Fk
-451 607 a(:) p Fg(e) p Ff 488 614 a(1) p Fg 516 607 a(:) p
-538 607 a(:) p 560 607 a(:) p Fi 581 607 a(l) p Fc 597
-614 a(n) p Fk 621 607 a(:) p Fg(e) p Fb 658 614 a(n) p
-Fk 1154 607 a(when) p Fi 1281 607 a(l) p Fc 1297 614
-a(i) p Fk 1324 607 a(=) p Fj 1376 607 a(;) p Fk 1417
-607 a(and) p Fg 1512 607 a(l) p Fj 1541 607 a(62) p 1588
-607 a(f) p Fi(l) p Fc 1629 614 a(1) p Fg 1660 607 a(:) p
-1682 607 a(:) p 1704 607 a(:) p Fi 1725 607 a(l) p Fc
-1741 614 a(n) p Fj 1765 607 a(g) 515 667 y(!) p Fg 579
-667 a(e) p Fk([) p Fe(None) p Fg 717 667 a(=x) p Fk(]) p
-Fi 799 667 a(l) p Fc 815 674 a(1) p Fk 837 667 a(:) p
-Fg(e) p Ff 874 674 a(1) p Fg 901 667 a(:) p 923 667 a(:) p
-945 667 a(:) p Fi 967 667 a(l) p Fc 983 674 a(n) p Fk
-1007 667 a(:) p Fg(e) p Fb 1044 674 a(n) p Fk 86 728
-a(\(\() p Fe(fun) p Fi 217 728 a(l) p Fk(:) p Fg 246
-728 a(x) p Fj 288 728 a(!) p Fg 352 728 a(e) p Fk(\)) p
-Fi 409 728 a(l) p Fc 425 735 a(1) p Fk 447 728 a(:) p
-Fg(e) p Ff 484 735 a(1) p Fg 511 728 a(:) p 533 728 a(:) p
-555 728 a(:) p Fi 577 728 a(l) p Fc 593 735 a(m) p Fk
-629 728 a(:) p Fg 642 728 a(e) p Fb 665 735 a(m) p Fk
-698 728 a(\)) p Fi 733 728 a(l) p Fc 749 735 a(m) p Ff(+) p
-Fc(1) p Fk 833 728 a(:) p Fg 846 728 a(e) p Fb 869 735
-a(m) p Ff(+1) p Fg 955 728 a(:) p 977 728 a(:) p 999
-728 a(:) p Fi 1021 728 a(l) p Fc 1037 735 a(n) p Fk 1061
-728 a(:) p Fg(e) p Fb 1098 735 a(n) p Fk 1373 728 a(when) p
-Fi 1501 728 a(l) p Fj 1530 728 a(62) p 1577 728 a(f) p
-Fi(l) p Fc 1618 735 a(1) p Fg 1648 728 a(:) p 1670 728
-a(:) p 1692 728 a(:) p Fi 1714 728 a(l) p Fc 1730 735
-a(m) p Fj 1765 728 a(g) 515 788 y(!) p Fk 579 788 a(\() p
-Fe(fun) p Fi 691 788 a(l) p Fk(:) p Fg 720 788 a(x) p
-Fj 761 788 a(!) p Fg 825 788 a(e) p Fk(\)) p Fi 883 788
-a(l) p Fc 899 795 a(1) p Fk 921 788 a(:) p Fg 934 788
-a(e) p Ff 957 795 a(1) p Fg 985 788 a(:) p 1007 788 a(:) p
-1029 788 a(:) p Fi 1051 788 a(l) p Fc 1067 795 a(n) p
-Fk 1091 788 a(:) p Fg 1104 788 a(e) p Fb 1127 795 a(n) p
-Fk 86 848 a(\(\() p Fe(fun) p Fk 217 848 a(?) p Fi(l) p
-Fk(:) p Fg 269 848 a(x) p Fj 311 848 a(!) p Fg 375 848
-a(e) p Fk(\)) p Fi 432 848 a(l) p Fc 448 855 a(1) p Fk
-470 848 a(:) p Fg(e) p Ff 507 855 a(1) p Fg 535 848 a(:) p
-557 848 a(:) p 579 848 a(:) p Fi 600 848 a(l) p Fc 616
-855 a(m) p Fk 652 848 a(:) p Fg 665 848 a(e) p Fb 688
-855 a(m) p Fk 721 848 a(\)) p Fi 756 848 a(l) p Fc 772
-855 a(m) p Ff(+) p Fc(1) p Fk 856 848 a(:) p Fg 869 848
-a(e) p Fb 892 855 a(m) p Ff(+1) p Fg 978 848 a(:) p 1000
-848 a(:) p 1022 848 a(:) p Fi 1044 848 a(l) p Fc 1060
-855 a(n) p Fk 1084 848 a(:) p Fg(e) p Fb 1121 855 a(n) p
-Fk 1261 848 a(when) p Fj 1388 848 a(f) p Fi(l) p Fg(;) p
-Fj 1451 848 a(;g) p 1530 848 a(6) m(\\) p 1577 848 a(f) p
-Fi(l) p Fc 1618 855 a(1) p Fg 1648 848 a(:) p 1670 848
-a(:) p 1692 848 a(:) p Fi 1714 848 a(l) p Fc 1730 855
-a(m) p Fj 1765 848 a(g) 515 908 y(!) p Fk 579 908 a(\() p
-Fe(fun) p Fk 691 908 a(?) p Fi(l) p Fk(:) p Fg 743 908
-a(x) p Fj 785 908 a(!) p Fg 848 908 a(e) p Fk(\)) p Fi
-906 908 a(l) p Fc 922 915 a(1) p Fk 944 908 a(:) p Fg(e) p
-Ff 981 915 a(1) p Fg 1008 908 a(:) p 1030 908 a(:) p
-1052 908 a(:) p Fi 1074 908 a(l) p Fc 1090 915 a(n) p
-Fk 1114 908 a(:) p Fg 1127 908 a(e) p Fb 1150 915 a(n) p
-Fi 11 1035 a(T) n(yping) p Fk 11 1127 a(Seman) o(tics) p
-240 1127 a(are) p 321 1127 a(k) o(ept) p 430 1127 a(throughout) p
-685 1127 a(compilation) p 950 1127 a(b) o(y) p 1018 1127
-a(disallo) o(wing) p 1269 1127 a(lab) q(el) p 1387 1127
-a(comm) o(utation) p 1684 1127 a(for) p 1759 1127 a(func-) 11
-1187 y(tion) p 116 1187 a(t) o(yp) q(es.) p 278 1187
-a(Ho) o(w) o(ev) o(er,) p 494 1187 a(the) p 583 1187
-a(original) p 764 1187 a(comfort) p 949 1187 a(of) p
-1009 1187 a(out-of-order) p 1283 1187 a(application) p
-1540 1187 a(is) p 1594 1187 a(reco) o(v) o(ered) p 1814
-1187 a(b) o(y) 11 1247 y(allo) o(wing) p 207 1247 a(argumen) o(t) p
-431 1247 a(reordering) p 670 1247 a(in) p 732 1247 a(application,) p
-1005 1247 a(when) p 1138 1247 a(the) p 1227 1247 a(function's) p
-1457 1247 a(t) o(yp) q(e) p 1572 1247 a(is) p Fh 1626
-1247 a(wel) r(l) p 1731 1247 a(known) p Fk 11 1308 a(\() p
-Fh(c.f.) p Fk 118 1308 a(p) q(olymorphic) p 400 1308
-a(metho) q(ds\).) p Fl 11 1452 a(V) p 56 1452 a(arian) n(ts) p
-Fk 11 1544 a(V) l(arian) o(t) p 187 1544 a(t) o(yping,) p
-355 1544 a(as) p 417 1544 a(it) p 468 1544 a(is) p 519
-1544 a(presen) o(ted) p 739 1544 a(in) p 798 1544 a(the) p
-884 1544 a(user's) p 1022 1544 a(man) o(ual,) p 1210
-1544 a(is) p 1261 1544 a(not) p 1350 1544 a(principal:) p
-1576 1544 a(in) p 1635 1544 a(some) p 1760 1544 a(cases) 11
-1605 y(t) o(ypabilit) o(y) p 239 1605 a(of) p 301 1605
-a(an) p 375 1605 a(expression) p 616 1605 a(ma) o(y) p
-728 1605 a(dep) q(end) p 904 1605 a(on) p 978 1605 a(the) p
-1069 1605 a(order) p 1202 1605 a(in) p 1265 1605 a(whic) o(h) p
-1411 1605 a(the) p 1502 1605 a(t) o(yping) p 1660 1605
-a(algorithm) 11 1665 y(pro) q(ceeds.) p Fe 133 1779 a(#) p
-184 1779 a(let) p 286 1779 a(f1) p 363 1779 a(\(x) p
-440 1779 a(:) p 491 1779 a([<) p 568 1779 a(a) p 620
-1779 a(b\(int\)]\)) p 850 1779 a(=) p 902 1779 a(\(\)) 184
-1839 y(let) p 286 1839 a(f2) p 363 1839 a(\(x) p 440
-1839 a(:) p 491 1839 a([<) p 568 1839 a(a]\)) p 671 1839
-a(=) p 722 1839 a(\(\)) 184 1899 y(let) p 286 1899 a(f3) p
-363 1899 a(\(x) p 440 1899 a(:) p 491 1899 a([<) p 568
-1899 a(a) p 620 1899 a(b\(bool\)]\)) p 876 1899 a(=) p
-927 1899 a(\(\);;) 133 1960 y(val) p 235 1960 a(f1) p
-312 1960 a(:) p 363 1960 a([<) p 440 1960 a(a) p 491
-1960 a(b\(int\)]) p 696 1960 a(->) p 773 1960 a(unit) p
-902 1960 a(=) p 953 1960 a(<fun>) 133 2020 y(val) p 235
-2020 a(f2) p 312 2020 a(:) p 363 2020 a([<) p 440 2020
-a(a]) p 517 2020 a(->) p 594 2020 a(unit) p 722 2020
-a(=) p 773 2020 a(<fun>) 133 2080 y(val) p 235 2080 a(f3) p
-312 2080 a(:) p 363 2080 a([<) p 440 2080 a(a) p 491
-2080 a(b\(bool\)]) p 722 2080 a(->) p 799 2080 a(unit) p
-927 2080 a(=) p 978 2080 a(<fun>) 133 2140 y(#) p 184
-2140 a(fun) p 286 2140 a(x) p 338 2140 a(->) p 414 2140
-a(f1) p 491 2140 a(x;) p 568 2140 a(f2) p 645 2140 a(x;) p
-722 2140 a(f3) p 799 2140 a(x;;) 133 2200 y(-) p 184
-2200 a(:) p 235 2200 a([<) p 312 2200 a(a]) p 389 2200
-a(->) p 466 2200 a(unit) p 594 2200 a(=) p 645 2200 a(<fun>) 133
-2260 y(#) p 184 2260 a(fun) p 286 2260 a(x) p 338 2260
-a(->) p 414 2260 a(f1) p 491 2260 a(x;) p 568 2260 a(f3) p
-645 2260 a(x;;) 133 2321 y(Character) o(s) p 414 2321
-a(18-19:) 133 2381 y(This) p 261 2381 a(expressio) o(n) p
-543 2381 a(has) p 645 2381 a(type) p 773 2381 a([<) p
-850 2381 a(a) p 902 2381 a(b\(int\)]) p 1107 2381 a(but) p
-1209 2381 a(is) p 1286 2381 a(here) p 1414 2381 a(used) p
-1542 2381 a(with) p 1670 2381 a(type) 184 2441 y([<) p
-261 2441 a(a) p 312 2441 a(b\(bool\)]) p Fk 84 2555 a(Here) p
-204 2555 a(the) p 292 2555 a(constrain) o(t) p 526 2555
-a(in) o(tro) q(duced) p 775 2555 a(b) o(y) p Fe 848 2555
-a(f2) p Fk 920 2555 a(hides) p 1049 2555 a(the) p 1138
-2555 a(constructor) p Fe 1401 2555 a(b) p Fk(,) p 1462
-2555 a(and) p 1562 2555 a(a) o(v) o(oids) p 1714 2555
-a(a) p 1760 2555 a(clash) 11 2615 y(b) q(et) o(w) o(een) p
-Fe 199 2615 a(int) p Fk 292 2615 a(and) p Fe 387 2615
-a(bool) p Fk(.) 84 2676 y(An) p 163 2676 a(easy) p 270
-2676 a(w) o(a) o(y) p 369 2676 a(to) p 428 2676 a(solv) o(e) p
-547 2676 a(this) p 642 2676 a(w) o(ould) p 784 2676 a(b) q(e) p
-850 2676 a(to) p 909 2676 a(restrict) p 1077 2676 a(hiding) p
-1226 2676 a(absen) o(t) p 1379 2676 a(lab) q(els) p 1515
-2676 a(to) p 1575 2676 a(generic) p 1739 2676 a(t) o(yp) q(es.) 11
-2736 y(This) p 124 2736 a(w) o(a) o(y) p 224 2736 a(the) p
-310 2736 a(second) p 469 2736 a(case) p 574 2736 a(w) o(ould) p
-718 2736 a(still) p 814 2736 a(fail,) p 913 2736 a(since) p
-Fe 1034 2736 a(x) p Fk 1077 2736 a(has) p 1166 2736 a(a) p
-1208 2736 a(monorphic) p 1451 2736 a(t) o(yp) q(e.) p
-1584 2736 a(This) p 1697 2736 a(solution) 11 2796 y(w) o(ould) p
-153 2796 a(b) q(e) p 219 2796 a(correct) p 382 2796 a(and) p
-477 2796 a(principal.) 926 2937 y(2) p eop
-PStoPSsaved restore
-%%Page: (2,3) 2
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 0.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-/showpage{}def/copypage{}def/erasepage{}def
-PStoPSxform concat
-3 2 bop Fk 84 168 a(Ho) o(w) o(ev) o(er,) p 293 168 a(one) p
-382 168 a(can) p 472 168 a(easily) p 606 168 a(see) p
-684 168 a(that) p 789 168 a(this) p 884 168 a(solution) p
-1068 168 a(is) p 1117 168 a(coun) o(ter-in) o(tuitiv) o(e.) p
-1504 168 a(F) l(or) p 1591 168 a(the) p 1675 168 a(user,) p
-Fe 1791 168 a(b) p Fk 1833 168 a(is) 11 229 y(already) p
-183 229 a(an) p 250 229 a(imp) q(ossible) p 488 229 a(constructor,) p
-759 229 a(and) p 854 229 a(ha) o(ving) p 1011 229 a(a) p
-1052 229 a(clash) p 1174 229 a(on) p 1242 229 a(it) p
-1291 229 a(is) p 1340 229 a(hard) p 1453 229 a(to) p
-1513 229 a(understand.) 84 289 y(Another) p 277 289 a(solution) p
-463 289 a(is) p 514 289 a(to) p 575 289 a(go) p 642 289
-a(the) p 728 289 a(opp) q(osite) p 924 289 a(w) o(a) o(y) l(.) p
-1044 289 a(T) l(o) p 1117 289 a(accept) p 1271 289 a(more) p
-1395 289 a(programs.) p 1634 289 a(This) p 1747 289 a(is) p
-1798 289 a(the) 11 349 y(w) o(a) o(y) p 109 349 a(w) o(e) p
-181 349 a(explore) p 351 349 a(here,) p 470 349 a(with) p
-581 349 a(an) p 649 349 a(unc) o(hanged) p 891 349 a(syn) o(tax.) p
-Fi 11 479 a(T) n(yping) p Fk 11 571 a(The) p 114 571
-a(idea) p 220 571 a(is) p 273 571 a(to) p 336 571 a(dela) o(y) p
-466 571 a(uni\014cation) p 711 571 a(on) p 782 571 a(constructor) p
-1043 571 a(un) o(til) p 1161 571 a(they) p 1274 571 a(are) p
-1359 571 a(explicitely) p 1595 571 a(kno) o(wn) p 1753
-571 a(to) p 1816 571 a(b) q(e) 11 631 y(presen) o(t.) p
-199 631 a(W) l(e) p 280 631 a(k) o(eep) p 390 631 a(the) p
-472 631 a(\() p Fg(T) t(;) p 546 631 a(U;) p 601 631
-a(L) p Fk(\)) p 666 631 a(represen) o(tation) p 983 631
-a(of) p 1036 631 a(v) m(arian) o(t) p 1200 631 a(t) o(yp) q(es,) p
-1341 631 a(but) p Fg 1428 631 a(T) p Fk 1478 631 a(is) p
-1525 631 a(no) p 1591 631 a(longer) p 1735 631 a(a) p
-1774 631 a(map) 11 692 y(from) p 126 692 a(constructors) p
-403 692 a(to) p 462 692 a(t) o(yp) q(es,) p 605 692 a(but) p
-694 692 a(from) p 809 692 a(constructors) p 1086 692
-a(to) p 1146 692 a(sets) p 1241 692 a(of) p 1297 692
-a(t) o(yp) q(es.) 84 752 y(When) p 230 752 a(w) o(e) p
-307 752 a(unify) p 436 752 a(t) o(w) o(o) p 532 752 a(v) m(arian) o(t) p
-702 752 a(t) o(yp) q(es,) p 850 752 a(the) p 938 752
-a(\014rst) p 1043 752 a(step) p 1150 752 a(is) p 1204
-752 a(just) p 1305 752 a(to) p 1369 752 a(tak) o(e) p
-1479 752 a(the) p 1567 752 a(union) p 1707 752 a(of) p
-1767 752 a(b) q(oth) 11 812 y(t) o(yping) p 162 812 a(en) o(vironmen) o
-(ts,) p 476 812 a(dropping) p 682 812 a(unnecessary) p
-952 812 a(t) o(yp) q(es.) 204 932 y(\() p Fg(T) p Ff
-252 939 a(1) p Fg 272 932 a(;) p 294 932 a(U) p Ff 327
-939 a(1) p Fg 346 932 a(;) p 368 932 a(L) p Ff 401 939
-a(1) p Fk 421 932 a(\)) p Fj 451 932 a(^) p Fk 495 932
-a(\() p Fg(T) p Ff 543 939 a(2) p Fg 563 932 a(;) p 585
-932 a(U) p Ff 618 939 a(2) p Fg 637 932 a(;) p 659 932
-a(L) p Ff 692 939 a(2) p Fk 712 932 a(\)) p 745 932 a(=) p
-797 932 a(\(\() p Fg(T) p Ff 864 939 a(1) p Fj 883 932
-a(j) p Fb 897 939 a(U) p Fa 921 944 a(1) p Fd 938 939
-a(\\) p Fb(U) p Fa 986 944 a(2) p Fk 1005 932 a(\)) p
-Fj 1035 932 a([) p Fk 1079 932 a(\() p Fg(T) p Ff 1127
-939 a(2) p Fj 1146 932 a(j) p Fb 1160 939 a(U) p Fa 1184
-944 a(1) p Fd 1201 939 a(\\) p Fb(U) p Fa 1249 944 a(2) p
-Fk 1268 932 a(\)) p Fg(;) p 1309 932 a(U) p Ff 1342 939
-a(1) p Fj 1373 932 a(\\) p Fg 1417 932 a(U) p Ff 1450
-939 a(2) p Fg 1470 932 a(;) p 1492 932 a(L) p Ff 1525
-939 a(1) p Fj 1556 932 a([) p Fg 1600 932 a(L) p Ff 1633
-939 a(2) p Fk 1653 932 a(\)) 84 1042 y(Here) p 203 1042
-a(the) p 291 1042 a(union) p 431 1042 a(of) p 490 1042
-a(t) o(w) o(o) p 587 1042 a(t) o(yping) p 742 1042 a(en) o(vironmen) o
-(ts) p 1046 1042 a(is) p 1099 1042 a(the) p 1187 1042
-a(p) q(oin) o(t) o(wise) p 1407 1042 a(union) p 1547
-1042 a(of) p 1606 1042 a(their) p 1727 1042 a(sets) p
-1826 1042 a(of) 11 1102 y(t) o(yp) q(es) p 140 1102 a(for) p
-214 1102 a(eac) o(h) p 324 1102 a(constructor.) 84 1162
-y(This) p 195 1162 a(\014rst) p 296 1162 a(step) p 399
-1162 a(nev) o(er) p 529 1162 a(fails.) 84 1222 y(In) p
-145 1222 a(a) p 186 1222 a(second) p 343 1222 a(step,) p
-460 1222 a(structural) p 685 1222 a(constrain) o(ts) p
-934 1222 a(are) p 1015 1222 a(enforced) p 1209 1222 a(on) p
-1277 1222 a(the) p 1361 1222 a(resulting) p 1562 1222
-a(t) o(yp) q(e) p 1672 1222 a(\() p Fg(T) t(;) p 1746
-1222 a(U;) p 1801 1222 a(L) p Fk(\).) 11 1282 y(First,) p
-Fg 144 1282 a(L) p Fk 195 1282 a(should) p 351 1282 a(b) q(e) p
-418 1282 a(included) p 614 1282 a(in) p Fg 672 1282 a(U) p
-Fk 710 1282 a(.) p 749 1282 a(Then,) p 892 1282 a(for) p
-967 1282 a(all) p 1036 1282 a(constructors) p 1314 1282
-a(app) q(earing) p 1542 1282 a(in) p Fg 1600 1282 a(L) p
-Fk(,) p 1664 1282 a(the) p 1749 1282 a(set) p 1826 1282
-a(of) 11 1343 y(t) o(yp) q(es) p 136 1343 a(asso) q(ciated) p
-365 1343 a(with) p 472 1343 a(eac) o(h) p 578 1343 a(constructor) p
-833 1343 a(is) p 878 1343 a(collapsed) p 1084 1343 a(b) o(y) p
-1148 1343 a(uni\014cation.) p 1407 1343 a(This) p 1515
-1343 a(can) p 1600 1343 a(b) q(e) p 1663 1343 a(expressed) 11
-1403 y(b) o(y) p 78 1403 a(rewriting) p 287 1403 a(rules,) p
-417 1403 a(where) p Fg 558 1403 a(e) p Fk 597 1403 a(is) p
-646 1403 a(a) p 687 1403 a(m) o(ulti-equation) p 1015
-1403 a(and) p Fg 1109 1403 a(\036) p Fk 1155 1403 a(a) p
-1195 1403 a(set) p 1271 1403 a(of) p 1327 1403 a(m) o(ultiequations) 249
-1509 y(if) p Fg 294 1509 a(L) p Fj 341 1509 a(6\032) p
-Fg 393 1509 a(U) p Fk 448 1509 a(then) p 559 1509 a(\() p
-Fg(T) t(;) p 633 1509 a(U;) p 688 1509 a(L) p Fk(\)) p
-753 1509 a(=) p Fg 805 1509 a(e) p Fj 839 1509 a(^) p
-Fg 883 1509 a(\036) p Fj 926 1509 a(\000) p 956 1509
-a(!) p 1020 1509 a(?) p Fk 249 1629 a(if) p Fg 294 1629
-a(l) p Fj 323 1629 a(2) p Fg 370 1629 a(L) p Fk 420 1629
-a(and) p Fg 515 1629 a(T) p Fk 551 1629 a(\() p Fg(l) p
-Fk 586 1629 a(\)) p 617 1629 a(=) p Fj 669 1629 a(f) p
-Fg(\034) p Ff 715 1636 a(1) p Fg 735 1629 a(;) p 757
-1629 a(:) p 779 1629 a(:) p 801 1629 a(:) p 822 1629
-a(;) p 844 1629 a(\034) p Fb 865 1636 a(n) p Fj 889 1629
-a(g) p Fk 930 1629 a(then) 298 1689 y(\() p Fg(T) t(;) p
-372 1689 a(U;) p 427 1689 a(L) p Fk(\)) p 492 1689 a(=) p
-Fg 544 1689 a(e) p Fj 577 1689 a(^) p Fg 622 1689 a(\036) p
-Fj 664 1689 a(\000) p 695 1689 a(!) p Fk 759 1689 a(\() p
-Fg(T) p Fj 814 1689 a(f) p Fg(l) p Fj 867 1689 a(7!) p
-Fg 931 1689 a(\034) p Ff 952 1696 a(1) p Fj 972 1689
-a(g) p Fg(;) p 1019 1689 a(U;) p 1074 1689 a(L) p Fk(\)) p
-1139 1689 a(=) p Fg 1191 1689 a(e) p Fj 1225 1689 a(^) p
-Fg 1269 1689 a(\034) p Ff 1290 1696 a(1) p Fk 1324 1689
-a(=) p Fg 1376 1689 a(:) p 1398 1689 a(:) p 1420 1689
-a(:) p Fk 1447 1689 a(=) p Fg 1498 1689 a(\034) p Fb
-1519 1696 a(n) p Fj 1554 1689 a(^) p Fg 1598 1689 a(\036) p
-Fk 84 1796 a(Optionally) p 331 1796 a(one) p 425 1796
-a(can) p 519 1796 a(add) p 619 1796 a(rules) p 740 1796
-a(that) p 850 1796 a(remo) o(v) o(e) p 1022 1796 a(a) p
-1067 1796 a(constructor) p Fg 1329 1796 a(l) p Fk 1366
-1796 a(from) p Fg 1486 1796 a(U) p Fk 1545 1796 a(if) p
-1594 1796 a(the) p 1683 1796 a(equation) 11 1856 y(obtained) p
-211 1856 a(from) p Fg 326 1856 a(T) p Fk 362 1856 a(\() p
-Fg(l) p Fk 397 1856 a(\)) p 431 1856 a(has) p 518 1856
-a(no) p 586 1856 a(solution.) p 790 1856 a(Suc) o(h) p
-908 1856 a(rules) p 1024 1856 a(w) o(ould) p 1167 1856
-a(b) q(e) p 1233 1856 a(sound) p 1374 1856 a(and) p 1469
-1856 a(complete.) p Fi 11 1986 a(Syn) n(tax) p 198 1986
-a(of) p 262 1986 a(t) n(yp) r(es) p Fk 11 2078 a(Thanks) p
-188 2078 a(to) p 250 2078 a(the) p 336 2078 a(go) q(o) q(d) p
-458 2078 a(prop) q(erties) p 689 2078 a(of) p 747 2078
-a(these) p 874 2078 a(constrain) o(ts,) p 1139 2078 a(the) p
-1226 2078 a(surface) p 1392 2078 a(syn) o(tax) p 1551
-2078 a(of) p 1608 2078 a(t) o(yp) q(es) p 1740 2078 a(w) o(ould) 11
-2138 y(only) p 118 2138 a(ha) o(v) o(e) p 230 2138 a(to) p
-290 2138 a(b) q(e) p 356 2138 a(sligh) o(tly) p 527 2138
-a(extended.) p Fh 590 2244 a(tag-typ) n(e) p Fk 798 2244
-a(::=) p Fh 904 2244 a(ident) p Fj 849 2304 a(j) p Fh
-904 2304 a(ident) p Fe 1031 2304 a(\() p Fh(typ) n(expr-list) p
-Fe(\)) p Fh 523 2365 a(typ) n(expr-list) p Fk 798 2365
-a(::=) p Fh 904 2365 a(typ) n(expr) p Fj 849 2425 a(j) p
-Fh 904 2425 a(typ) n(expr) p Fe 1078 2425 a(&) p Fh 1120
-2425 a(typ) n(expr-list) p Fk 84 2531 a(Notice) p 234
-2531 a(that) p 336 2531 a(a) p 373 2531 a(0-ary) p 496
-2531 a(constructor) p 751 2531 a(and) p 842 2531 a(an) p
-907 2531 a(1-ary) p 1030 2531 a(construtor) p 1262 2531
-a(are) p 1340 2531 a(con) o(tradictory) l(,) p 1648 2531
-a(and) p 1740 2531 a(w) o(ould) 11 2592 y(result) p 146
-2592 a(in) p 203 2592 a(the) p 287 2592 a(absence) p
-466 2592 a(of) p 522 2592 a(this) p 617 2592 a(constructor.) 926
-2937 y(3) p eop
-PStoPSsaved restore
-userdict/PStoPSsaved save put
-PStoPSmatrix setmatrix
-595.000000 421.271378 translate
-90 rotate
-0.706651 dup scale
-userdict/PStoPSmatrix matrix currentmatrix put
-userdict/PStoPSclip{0 0 moveto
- 595.000000 0 rlineto 0 842.000000 rlineto -595.000000 0 rlineto
- closepath}put initclip
-PStoPSxform concat
-4 3 bop Fi 11 168 a(Discussion) p Fk 11 261 a(Suc) o(h) p
-133 261 a(a) p 179 261 a(c) o(hange) p 345 261 a(has) p
-436 261 a(the) p 525 261 a(ma) s(jor) p 672 261 a(adv) m(an) o(tage) p
-907 261 a(of) p 967 261 a(b) q(oth) p 1087 261 a(reco) o(v) o(ering) p
-1324 261 a(principalit) o(y) p 1589 261 a(and) p 1688
-261 a(a) o(v) o(oiding) 11 321 y(unin) o(tuitiv) o(e) p
-266 321 a(error) p 392 321 a(messages.) p 640 321 a(Constrain) o(ts) p
-909 321 a(created) p 1087 321 a(in) p 1152 321 a(suc) o(h) p
-1269 321 a(a) p 1317 321 a(w) o(a) o(y) p 1423 321 a(are) p
-1512 321 a(v) o(ery) p 1626 321 a(ligh) o(t:) p 1772
-321 a(they) 11 381 y(alw) o(a) o(ys) p 165 381 a(app) q(ear) p
-325 381 a(inside) p 463 381 a(a) p 502 381 a(v) m(arian) o(t) p
-666 381 a(t) o(yp) q(e,) p 788 381 a(and) p 882 381 a(if) p
-926 381 a(the) p 1008 381 a(v) m(arian) o(t) p 1172 381
-a(t) o(yp) q(e) p 1281 381 a(do) q(es) p 1390 381 a(not) p
-1475 381 a(app) q(ear) p 1635 381 a(in) p 1691 381 a(the) p
-1774 381 a(\014nal) 11 441 y(t) o(yp) q(e) p 120 441
-a(sc) o(heme,) p 301 441 a(then) p 412 441 a(the) p 496
-441 a(constrain) o(t) p 725 441 a(can) p 815 441 a(b) q(e) p
-881 441 a(discarded) p 1098 441 a(safely) l(.) 84 501
-y(On) p 165 501 a(the) p 249 501 a(other) p 376 501 a(hand,) p
-512 501 a(there) p 637 501 a(are) p 718 501 a(t) o(w) o(o) p
-810 501 a(dra) o(wbac) o(ks.) p Fj 83 616 a(\017) p Fk
-133 616 a(Some) p 259 616 a(errors) p 393 616 a(will) p
-482 616 a(b) q(e) p 544 616 a(dela) o(y) o(ed) p 715
-616 a(longer) p 858 616 a(than) p 968 616 a(no) o(w,) p
-1080 616 a(un) o(til) p 1191 616 a(a) p 1228 616 a(construtor) p
-1460 616 a(is) p 1505 616 a(actually) p 1687 616 a(included) 133
-676 y(in) p Fg 189 676 a(L) p Fk(.) p 258 676 a(It) p
-311 676 a(is) p 360 676 a(not) p 446 676 a(clear) p 563
-676 a(ho) o(w) p 665 676 a(damageable) p 930 676 a(it) p
-979 676 a(is.) p Fj 83 777 a(\017) p Fk 133 777 a(While) p
-272 777 a(t) o(yp) q(e) p 378 777 a(inference) p 579
-777 a(is) p 625 777 a(simple) p 774 777 a(and) p 865
-777 a(costless) p 1036 777 a(for) p 1108 777 a(this) p
-1200 777 a(extension,) p 1426 777 a(simpli\014cation) p
-1724 777 a(of) p 1776 777 a(con-) 133 838 y(strain) o(ts) p
-310 838 a(|marking) p 551 838 a(constructors) p 830 838
-a(with) p 943 838 a(unsolv) m(able) p 1182 838 a(constrain) o(ts) p
-1432 838 a(as) p 1494 838 a(absen) o(t,) p 1663 838 a(and) p
-1760 838 a(elim-) 133 898 y(inating) p 300 898 a(redundan) o(t) p
-536 898 a(t) o(yp) q(es) p 667 898 a(in) p 726 898 a(constrain) o(ts|) p
-1025 898 a(is) p 1076 898 a(a) p 1119 898 a(bit) p 1197
-898 a(more) p 1320 898 a(exp) q(ensiv) o(e.) p 1565 898
-a(Also,) p 1691 898 a(allo) o(wing) 133 958 y(suc) o(h) p
-244 958 a(constrained) p 506 958 a(t) o(yp) q(es) p 637
-958 a(inside) p 777 958 a(signatures) p 1010 958 a(w) o(ould) p
-1154 958 a(mean) p 1286 958 a(ha) o(ving) p 1444 958
-a(to) p 1506 958 a(solv) o(e) p 1627 958 a(a) p 1669
-958 a(matc) o(hing) 133 1018 y(problem,) p 333 1018 a(whic) o(h) p
-469 1018 a(is) p 514 1018 a(exp) q(onen) o(tial) p 772
-1018 a(in) p 825 1018 a(the) p 906 1018 a(n) o(um) o(b) q(er) p
-1080 1018 a(of) p 1132 1018 a(connected) p 1356 1018
-a(constrain) o(ts) p 1600 1018 a(inside) p 1735 1018
-a(a) p 1772 1018 a(t) o(yp) q(e) 133 1078 y(sc) o(heme.) 84
-1193 y(Reasonably) p 340 1193 a(e\016cien) o(t) p 516
-1193 a(algorithms) p 754 1193 a(exist) p 866 1193 a(to) p
-922 1193 a(solv) o(e) p 1038 1193 a(these) p 1159 1193
-a(problems,) p 1379 1193 a(so) p 1435 1193 a(the) p 1515
-1193 a(di\016cult) o(y) p 1715 1193 a(is) p 1760 1193
-a(more) 11 1253 y(in) p 67 1253 a(the) p 151 1253 a(increased) p
-363 1253 a(complexit) o(y) p 611 1253 a(of) p 667 1253
-a(the) p 751 1253 a(t) o(yp) q(e-c) o(hec) o(k) o(er) p
-1031 1253 a(than) p 1145 1253 a(in) p 1202 1253 a(run-time) p
-1402 1253 a(cost.) p Fl 11 1397 a(Other) p 205 1397 a(features) p
-Fk 11 1490 a(Ob) s(jectiv) o(e) p 238 1490 a(Lab) q(el) p
-380 1490 a(con) o(tains) p 579 1490 a(t) o(w) o(o) p
-678 1490 a(other) p 812 1490 a(features:) p 1029 1490
-a(p) q(olymorphic) p 1318 1490 a(metho) q(ds) p 1521
-1490 a(and) p 1623 1490 a(t) o(yp) q(e-driv) o(en) 11
-1550 y(access) p 153 1550 a(of) p 208 1550 a(records.) p
-394 1550 a(Both) p 514 1550 a(of) p 568 1550 a(them) p
-692 1550 a(use) p 775 1550 a(the) p 857 1550 a(same) p
-978 1550 a(metho) q(d) p 1154 1550 a(of) p 1209 1550
-a(enforcing) p 1417 1550 a(principalit) o(y) p 1676 1550
-a(of) p 1730 1550 a(t) o(yping) 11 1610 y(through) p
-191 1610 a(tracing) p 351 1610 a(user) p 450 1610 a(pro) o(vided) p
-647 1610 a(t) o(yp) q(e) p 752 1610 a(information.) p
-1034 1610 a(With) p 1155 1610 a(this) p 1246 1610 a(tracing,) p
-1422 1610 a(their) p 1534 1610 a(implem) o(en) n(tation) 11
-1670 y(is) p 60 1670 a(v) o(ery) p 167 1670 a(easy) l(,) p
-283 1670 a(but) p 373 1670 a(without) p 554 1670 a(it) p
-603 1670 a(they) p 713 1670 a(lo) q(ose) p 834 1670 a(principalit) o(y)
-l(.) 84 1730 y(While) p 229 1730 a(these) p 357 1730
-a(features) p 543 1730 a(pro) o(vide) p 720 1730 a(some) p
-845 1730 a(comfort) p 1029 1730 a(in) p 1089 1730 a(writing) p
-1260 1730 a(user) p 1366 1730 a(programs,) p 1598 1730
-a(they) p 1711 1730 a(are) p 1795 1730 a(not) 11 1791
-y(strictly) p 182 1791 a(necessary) p 403 1791 a(for) p
-482 1791 a(the) p 571 1791 a(v) m(arious) p 742 1791
-a(libraries) p 934 1791 a(coming) p 1107 1791 a(with) p
-1223 1791 a(O'Labl) p 1391 1791 a(\(LablTk,) p 1602 1791
-a(LablGL) p 1787 1791 a(and) 11 1851 y(LablGTK\).) 926
-2937 y(4) p eop
-PStoPSsaved restore
-%%Trailer
-end
-userdict /end-hook known{end-hook}if
-%%EOF

diff --git a/testlabl/objvariant.diffs b/testlabl/objvariant.diffs
deleted file mode 100644 (file)
index 75deb24..0000000
--- a/testlabl/objvariant.diffs
+++ /dev/null
@@ -1,354 +0,0 @@
-? objvariants-3.09.1.diffs
-? objvariants.diffs
-Index: btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.37.4.1
-diff -u -r1.37.4.1 btype.ml
---- btype.ml   5 Dec 2005 13:18:42 -0000       1.37.4.1
-+++ btype.ml   16 Jan 2006 02:23:14 -0000
-@@ -177,7 +177,8 @@
-     Tvariant row -> iter_row f row
-   | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
-       Misc.may (fun (_,l) -> List.iter f l) row.row_name;
--      List.iter f row.row_bound
-+      List.iter f row.row_bound;
-+      List.iter (fun (s,k,t) -> f t) row.row_object
-   | _ -> assert false
- 
- let iter_type_expr f ty =
-@@ -224,7 +225,9 @@
-     | Some (path, tl) -> Some (path, List.map f tl) in
-   { row_fields = fields; row_more = more;
-     row_bound = !bound; row_fixed = row.row_fixed && fixed;
--    row_closed = row.row_closed; row_name = name; }
-+    row_closed = row.row_closed; row_name = name;
-+    row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object;
-+  }
- 
- let rec copy_kind = function
-     Fvar{contents = Some k} -> copy_kind k
-Index: ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.197.2.6
-diff -u -r1.197.2.6 ctype.ml
---- ctype.ml   15 Dec 2005 02:28:38 -0000      1.197.2.6
-+++ ctype.ml   16 Jan 2006 02:23:15 -0000
-@@ -1421,7 +1421,7 @@
-   newgenty
-     (Tvariant
-        {row_fields = fields; row_closed = closed; row_more = newvar();
--        row_bound = []; row_fixed = false; row_name = None })
-+        row_bound = []; row_fixed = false; row_name = None; row_object=[]})
- 
- (**** Unification ****)
- 
-@@ -1724,8 +1724,11 @@
-     else None
-   in
-   let bound = row1.row_bound @ row2.row_bound in
-+  let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in
-+  let row_object = row1.row_object @ miss2 in
-   let row0 = {row_fields = []; row_more = more; row_bound = bound;
--              row_closed = closed; row_fixed = fixed; row_name = name} in
-+              row_closed = closed; row_fixed = fixed; row_name = name;
-+              row_object = row_object } in
-   let set_more row rest =
-     let rest =
-       if closed then
-@@ -1758,6 +1761,18 @@
-           raise (Unify ((mkvariant [l,f1] true,
-                          mkvariant [l,f2] true) :: trace)))
-       pairs;
-+    List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs;
-+    if row_object <> [] then begin
-+      List.iter
-+        (fun (l,f) ->
-+          match row_field_repr f with
-+            Rpresent (Some ty) ->
-+              let fi = build_fields generic_level row_object (newgenvar()) in
-+              unify env (newgenty (Tobject (fi, ref None))) ty
-+          | Rpresent None -> raise (Unify [])
-+          | _ -> ())
-+        (row_repr row1).row_fields
-+    end;
-   with exn ->
-     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
-   end
-@@ -2789,7 +2804,8 @@
-       let row =
-         { row_fields = List.map fst fields; row_more = newvar();
-           row_bound = !bound; row_closed = posi; row_fixed = false;
--          row_name = if c > Unchanged then None else row.row_name }
-+          row_name = if c > Unchanged then None else row.row_name;
-+          row_object = [] }
-       in
-       (newty (Tvariant row), Changed)
-   | Tobject (t1, _) ->
-Index: oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- oprint.ml  23 Mar 2005 03:08:37 -0000      1.22
-+++ oprint.ml  16 Jan 2006 02:23:15 -0000
-@@ -185,7 +185,7 @@
-       fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
-   | Otyp_stuff s -> fprintf ppf "%s" s
-   | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
--  | Otyp_variant (non_gen, row_fields, closed, tags) ->
-+  | Otyp_variant (non_gen, row_fields, closed, tags, obj) ->
-       let print_present ppf =
-         function
-           None | Some [] -> ()
-@@ -198,12 +198,17 @@
-               ppf fields
-         | Ovar_name (id, tyl) ->
-             fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
-+      and print_object ppf obj =
-+        if obj <> [] then
-+          fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj
-       in
--      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
-+      fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a%a ]@]"
-+        (if non_gen then "_" else "")
-         (if closed then if tags = None then " " else "< "
-          else if tags = None then "> " else "? ")
-         print_fields row_fields
-         print_present tags
-+        print_object obj
-   | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
-       fprintf ppf "@[<1>(%a)@]" print_out_type ty
-   | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
-Index: outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- outcometree.mli    23 Mar 2005 03:08:37 -0000      1.14
-+++ outcometree.mli    16 Jan 2006 02:23:15 -0000
-@@ -59,6 +59,7 @@
-   | Otyp_var of bool * string
-   | Otyp_variant of
-       bool * out_variant * bool * (string list) option
-+      * (string * out_type) list
-   | Otyp_poly of string list * out_type
- and out_variant =
-   | Ovar_fields of (string * bool * out_type list) list
-Index: printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.139.2.2
-diff -u -r1.139.2.2 printtyp.ml
---- printtyp.ml        7 Dec 2005 23:37:27 -0000       1.139.2.2
-+++ printtyp.ml        16 Jan 2006 02:23:15 -0000
-@@ -244,7 +244,10 @@
-             visited_objects := px :: !visited_objects;
-           match row.row_name with
-           | Some(p, tyl) when namable_row row ->
--              List.iter (mark_loops_rec visited) tyl
-+              List.iter (mark_loops_rec visited) tyl;
-+              if not (static_row row) then
-+                List.iter (fun (s,k,t) -> mark_loops_rec visited t)
-+                  row.row_object
-           | _ ->
-               iter_row (mark_loops_rec visited) {row with row_bound = []}
-          end
-@@ -343,25 +346,27 @@
-                | _ -> false)
-             fields in
-         let all_present = List.length present = List.length fields in
-+        let static = row.row_closed && all_present in
-+        let obj =
-+          if static then [] else
-+          List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object
-+        in
-+        let tags = if all_present then None else Some (List.map fst present) in
-         begin match row.row_name with
-         | Some(p, tyl) when namable_row row ->
-             let id = tree_of_path p in
-             let args = tree_of_typlist sch tyl in
--            if row.row_closed && all_present then
-+            if static then
-               Otyp_constr (id, args)
-             else
-               let non_gen = is_non_gen sch px in
--              let tags =
--                if all_present then None else Some (List.map fst present) in
-               Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
--                            row.row_closed, tags)
-+                            row.row_closed, tags, obj)
-         | _ ->
--            let non_gen =
--              not (row.row_closed && all_present) && is_non_gen sch px in
-+            let non_gen = not static && is_non_gen sch px in
-             let fields = List.map (tree_of_row_field sch) fields in
--            let tags =
--              if all_present then None else Some (List.map fst present) in
--            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
-+            Otyp_variant (non_gen, Ovar_fields fields, row.row_closed,
-+                          tags, obj)
-         end
-     | Tobject (fi, nm) ->
-         tree_of_typobject sch fi nm
-Index: typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.176.2.2
-diff -u -r1.176.2.2 typecore.ml
---- typecore.ml        11 Dec 2005 09:56:33 -0000      1.176.2.2
-+++ typecore.ml        16 Jan 2006 02:23:15 -0000
-@@ -170,7 +170,8 @@
-       (* Force check of well-formedness *)
-       unify_pat pat.pat_env pat
-         (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
--                        row_bound=[]; row_fixed=false; row_name=None}));
-+                        row_bound=[]; row_fixed=false; row_name=None;
-+                        row_object=[]}));
-   | _ -> ()
- 
- let rec iter_pattern f p =
-@@ -251,7 +252,7 @@
-       let ty = may_map (build_as_type env) p' in
-       newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
-                       row_bound=[]; row_name=None;
--                      row_fixed=false; row_closed=false})
-+                      row_fixed=false; row_closed=false; row_object=[]})
-   | Tpat_record lpl ->
-       let lbl = fst(List.hd lpl) in
-       if lbl.lbl_private = Private then p.pat_type else
-@@ -318,7 +319,8 @@
-       ([],[]) fields in
-   let row =
-     { row_fields = List.rev fields; row_more = newvar(); row_bound = !bound;
--      row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
-+      row_closed = false; row_fixed = false; row_name = Some (path, tyl);
-+      row_object = [] }
-   in
-   let ty = newty (Tvariant row) in
-   let gloc = {loc with Location.loc_ghost=true} in
-@@ -428,7 +430,8 @@
-                   row_closed = false;
-                   row_more = newvar ();
-                   row_fixed = false;
--                  row_name = None } in
-+                  row_name = None;
-+                  row_object = [] } in
-       rp {
-         pat_desc = Tpat_variant(l, arg, row);
-         pat_loc = sp.ppat_loc;
-@@ -976,7 +979,8 @@
-                                   row_bound = [];
-                                   row_closed = false;
-                                   row_fixed = false;
--                                  row_name = None});
-+                                  row_name = None;
-+                                  row_object = []});
-         exp_env = env }
-   | Pexp_record(lid_sexp_list, opt_sexp) ->
-       let ty = newvar() in
-@@ -1261,8 +1265,30 @@
-                   assert false
-               end
-           | _ ->
--              (Texp_send(obj, Tmeth_name met),
--               filter_method env met Public obj.exp_type)
-+              let obj, met_ty =
-+                match expand_head env obj.exp_type with
-+                  {desc = Tvariant _} ->
-+                    let exp_ty = newvar () in
-+                    let met_ty = filter_method env met Public exp_ty in
-+                    let row =
-+                      {row_fields=[]; row_more=newvar();
-+                       row_bound=[]; row_closed=false;
-+                       row_fixed=false; row_name=None;
-+                       row_object=[met, Fpresent, met_ty]} in
-+                    unify_exp env obj (newty (Tvariant row));
-+                    let prim = Primitive.parse_declaration 1 ["%field1"] in
-+                    let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in
-+                    let vd = {val_type = ty; val_kind = Val_prim prim} in
-+                    let esnd =
-+                      {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd);
-+                       exp_loc = Location.none; exp_type = ty; exp_env = env}
-+                    in
-+                    ({obj with exp_type = exp_ty;
-+                      exp_desc = Texp_apply(esnd,[Some obj, Required])},
-+                     met_ty)
-+                | _ -> (obj, filter_method env met Public obj.exp_type)
-+              in
-+              (Texp_send(obj, Tmeth_name met), met_ty)
-         in
-         if !Clflags.principal then begin
-           end_def ();
-Index: types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- types.ml   9 Dec 2004 12:40:53 -0000       1.25
-+++ types.ml   16 Jan 2006 02:23:15 -0000
-@@ -44,7 +44,9 @@
-       row_bound: type_expr list;
-       row_closed: bool;
-       row_fixed: bool;
--      row_name: (Path.t * type_expr list) option }
-+      row_name: (Path.t * type_expr list) option;
-+      row_object: (string * field_kind * type_expr) list;
-+    }
- 
- and row_field =
-     Rpresent of type_expr option
-Index: types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- types.mli  9 Dec 2004 12:40:53 -0000       1.25
-+++ types.mli  16 Jan 2006 02:23:15 -0000
-@@ -43,7 +43,9 @@
-       row_bound: type_expr list;
-       row_closed: bool;
-       row_fixed: bool;
--      row_name: (Path.t * type_expr list) option }
-+      row_name: (Path.t * type_expr list) option;
-+      row_object: (string * field_kind * type_expr) list;
-+    }
- 
- and row_field =
-     Rpresent of type_expr option
-Index: typetexp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
-retrieving revision 1.54
-diff -u -r1.54 typetexp.ml
---- typetexp.ml        22 Jul 2005 06:42:36 -0000      1.54
-+++ typetexp.ml        16 Jan 2006 02:23:15 -0000
-@@ -215,7 +215,8 @@
-           in
-           let row = { row_closed = true; row_fields = fields;
-                       row_bound = !bound; row_name = Some (path, args);
--                      row_fixed = false; row_more = newvar () } in
-+                      row_fixed = false; row_more = newvar ();
-+                      row_object = [] } in
-           let static = Btype.static_row row in
-           let row =
-             if static then row else
-@@ -262,7 +263,7 @@
-       let mkfield l f =
-         newty (Tvariant {row_fields=[l,f]; row_more=newvar();
-                          row_bound=[]; row_closed=true;
--                         row_fixed=false; row_name=None}) in
-+                         row_fixed=false; row_name=None; row_object=[]}) in
-       let add_typed_field loc l f fields =
-         try
-           let f' = List.assoc l fields in
-@@ -345,7 +346,7 @@
-       let row =
-         { row_fields = List.rev fields; row_more = newvar ();
-           row_bound = !bound; row_closed = closed;
--          row_fixed = false; row_name = !name } in
-+          row_fixed = false; row_name = !name; row_object = [] } in
-       let static = Btype.static_row row in
-       let row =
-         if static then row else

diff --git a/testlabl/objvariant.ml b/testlabl/objvariant.ml
deleted file mode 100644 (file)
index 3233e03..0000000
--- a/testlabl/objvariant.ml
+++ /dev/null
@@ -1,42 +0,0 @@
-(* use with [cvs update -r objvariants typing] *)
-
-let f (x : [> ]) = x#m 3;;
-let o = object method m x = x+2 end;;
-f (`A o);;
-let l = [`A o; `B(object method m x = x -2 method y = 3 end)];;
-List.map f l;;
-let g = function `A x -> x#m 3 | `B x -> x#y;;
-List.map g l;;
-fun x -> ignore (x=f); List.map x l;;
-fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;;
-
-
-class cvar name =
-  object
-    method name = name
-    method print ppf = Format.pp_print_string ppf name
-  end
-
-type var = [`Var of cvar]
-
-class cint n =
-  object
-    method n = n
-    method print ppf = Format.pp_print_int ppf n
-  end
-
-class ['a] cadd (e1 : 'a) (e2 : 'a) =
-  object
-    constraint 'a = [> ]
-    method e1 = e1
-    method e2 = e2
-    method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print
-  end
-
-type 'a expr = [var | `Int of cint | `Add of 'a cadd]
-
-type expr1 = expr1 expr
-
-let print = Format.printf "%t@."
-
-let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2)))

diff --git a/testlabl/printers.ml b/testlabl/printers.ml
deleted file mode 100644 (file)
index c80c42d..0000000
--- a/testlabl/printers.ml
+++ /dev/null
@@ -1,11 +0,0 @@
-(* $Id$ *)
-
-open Types
-
-let ignore_abbrevs ppf ab =
-  let s = match ab with
-    Mnil -> "Mnil"
-  | Mlink _ -> "Mlink _"
-  | Mcons _ -> "Mcons _"
-  in
-  Format.pp_print_string ppf s

diff --git a/testlabl/sigsubst.ml b/testlabl/sigsubst.ml
deleted file mode 100644 (file)
index 9b6c957..0000000
--- a/testlabl/sigsubst.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-module type Printable = sig
-  type t
-  val print : Format.formatter -> t -> unit
-end
-module type Comparable = sig
-  type t
-  val compare : t -> t -> int
-end
-module type PrintableComparable = sig
-  include Printable
-  include Comparable with type t = t
-end
-module type PrintableComparable = sig
-  type t
-  include Printable with type t := t
-  include Comparable with type t := t
-end
-module type PrintableComparable = sig
-  include Printable
-  include Comparable with type t := t
-end
-module type ComparableInt = Comparable with type t := int
-
-module type S = sig type t val f : t -> t end
-module type S' = S with type t := int
-
-module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
-module type S1 = S with type 'a t := 'a list
-module type S2 = sig
-  type 'a dict = (string * 'a) list
-  include S with type 'a t := 'a dict
-end
-
-
-module type S =
-  sig module T : sig type exp type arg end val f : T.exp -> T.arg end
-module M = struct type exp = string type arg = int end
-module type S' = S with module T := M

diff --git a/testlabl/tests.ml b/testlabl/tests.ml
deleted file mode 100644 (file)
index c39d152..0000000
--- a/testlabl/tests.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-(* $Id$ *)
-
-let f1 = function `a x -> x=1 | `b -> true
-let f2 = function `a x -> x | `b -> true
-let f3 = function `b -> true
-let f x = f1 x && f2 x
-
-let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
-  String.sub s pos len
-
-let cCAMLtoTKpack_options w = function
-        `After v1 -> "-after"
-        | `Anchor v1 -> "-anchor"
-        | `Before v1 -> "-before"
-        | `Expand v1 -> "-expand"
-        | `Fill v1 -> "-fill"
-        | `In v1 -> "-in"
-        | `Ipadx v1 -> "-ipadx"
-        | `Ipady v1 -> "-ipady"
-        | `Padx v1 -> "-padx"
-        | `Pady v1 -> "-pady"
-        | `Side v1 -> "-side"

diff --git a/testlabl/valvirt.diffs b/testlabl/valvirt.diffs
deleted file mode 100644 (file)
index 2cf5574..0000000
--- a/testlabl/valvirt.diffs
+++ /dev/null
@@ -1,2349 +0,0 @@
-Index: utils/warnings.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.ml,v
-retrieving revision 1.23
-diff -u -r1.23 warnings.ml
---- utils/warnings.ml  15 Sep 2005 03:09:26 -0000      1.23
-+++ utils/warnings.ml  5 Apr 2006 02:25:59 -0000
-@@ -26,7 +26,7 @@
-   | Statement_type                   (* S *)
-   | Unused_match                     (* U *)
-   | Unused_pat
--  | Hide_instance_variable of string (* V *)
-+  | Instance_variable_override of string (* V *)
-   | Illegal_backslash                (* X *)
-   | Implicit_public_methods of string list
-   | Unerasable_optional_argument
-@@ -54,7 +54,7 @@
-   | Statement_type ->           's'
-   | Unused_match
-   | Unused_pat ->               'u'
--  | Hide_instance_variable _ -> 'v'
-+  | Instance_variable_override _ -> 'v'
-   | Illegal_backslash
-   | Implicit_public_methods _
-   | Unerasable_optional_argument
-@@ -126,9 +126,9 @@
-       String.concat " "
-         ("the following methods are overridden \
-           by the inherited class:\n " :: slist)
--  | Hide_instance_variable lab ->
--      "this definition of an instance variable " ^ lab ^
--      " hides a previously\ndefined instance variable of the same name."
-+  | Instance_variable_override lab ->
-+      "the instance variable " ^ lab ^ " is overridden.\n" ^
-+      "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)"
-   | Partial_application ->
-       "this function application is partial,\n\
-        maybe some arguments are missing."
-Index: utils/warnings.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/utils/warnings.mli,v
-retrieving revision 1.16
-diff -u -r1.16 warnings.mli
---- utils/warnings.mli 15 Sep 2005 03:09:26 -0000      1.16
-+++ utils/warnings.mli 5 Apr 2006 02:25:59 -0000
-@@ -26,7 +26,7 @@
-   | Statement_type                   (* S *)
-   | Unused_match                     (* U *)
-   | Unused_pat
--  | Hide_instance_variable of string (* V *)
-+  | Instance_variable_override of string (* V *)
-   | Illegal_backslash                (* X *)
-   | Implicit_public_methods of string list
-   | Unerasable_optional_argument
-Index: parsing/parser.mly
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parser.mly,v
-retrieving revision 1.123
-diff -u -r1.123 parser.mly
---- parsing/parser.mly 23 Mar 2005 03:08:37 -0000      1.123
-+++ parsing/parser.mly 5 Apr 2006 02:25:59 -0000
-@@ -623,6 +623,8 @@
-       { [] }
-   | class_fields INHERIT class_expr parent_binder
-       { Pcf_inher ($3, $4) :: $1 }
-+  | class_fields VAL virtual_value
-+      { Pcf_valvirt $3 :: $1 }
-   | class_fields VAL value
-       { Pcf_val $3 :: $1 }
-   | class_fields virtual_method
-@@ -638,14 +640,20 @@
-     AS LIDENT
-           { Some $2 }
-   | /* empty */
--          {None}
-+          { None }
-+;
-+virtual_value:
-+    MUTABLE VIRTUAL label COLON core_type
-+      { $3, Mutable, $5, symbol_rloc () }
-+  | VIRTUAL mutable_flag label COLON core_type
-+      { $3, $2, $5, symbol_rloc () }
- ;
- value:
--        mutable_flag label EQUAL seq_expr
--          { $2, $1, $4, symbol_rloc () }
--      | mutable_flag label type_constraint EQUAL seq_expr
--          { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
--            symbol_rloc () }
-+    mutable_flag label EQUAL seq_expr
-+      { $2, $1, $4, symbol_rloc () }
-+  | mutable_flag label type_constraint EQUAL seq_expr
-+      { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))),
-+        symbol_rloc () }
- ;
- virtual_method:
-     METHOD PRIVATE VIRTUAL label COLON poly_type
-@@ -711,8 +719,12 @@
-   | class_sig_fields CONSTRAINT constrain       { Pctf_cstr  $3 :: $1 }
- ;
- value_type:
--    mutable_flag label COLON core_type
--      { $2, $1, Some $4, symbol_rloc () }
-+    VIRTUAL mutable_flag label COLON core_type
-+      { $3, $2, Virtual, $5, symbol_rloc () }
-+  | MUTABLE virtual_flag label COLON core_type
-+      { $3, Mutable, $2, $5, symbol_rloc () }
-+  | label COLON core_type
-+      { $1, Immutable, Concrete, $3, symbol_rloc () }
- ;
- method_type:
-     METHOD private_flag label COLON poly_type
-Index: parsing/parsetree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/parsetree.mli,v
-retrieving revision 1.42
-diff -u -r1.42 parsetree.mli
---- parsing/parsetree.mli      23 Mar 2005 03:08:37 -0000      1.42
-+++ parsing/parsetree.mli      5 Apr 2006 02:25:59 -0000
-@@ -152,7 +152,7 @@
- 
- and class_type_field =
-     Pctf_inher of class_type
--  | Pctf_val   of (string * mutable_flag * core_type option * Location.t)
-+  | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t)
-   | Pctf_virt  of (string * private_flag * core_type * Location.t)
-   | Pctf_meth  of (string * private_flag * core_type * Location.t)
-   | Pctf_cstr  of (core_type * core_type * Location.t)
-@@ -179,6 +179,7 @@
- 
- and class_field =
-     Pcf_inher of class_expr * string option
-+  | Pcf_valvirt of (string * mutable_flag * core_type * Location.t)
-   | Pcf_val   of (string * mutable_flag * expression * Location.t)
-   | Pcf_virt  of (string * private_flag * core_type * Location.t)
-   | Pcf_meth  of (string * private_flag * expression * Location.t)
-Index: parsing/printast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/parsing/printast.ml,v
-retrieving revision 1.29
-diff -u -r1.29 printast.ml
---- parsing/printast.ml        4 Jan 2006 16:55:50 -0000       1.29
-+++ parsing/printast.ml        5 Apr 2006 02:25:59 -0000
-@@ -353,10 +353,11 @@
-   | Pctf_inher (ct) ->
-       line i ppf "Pctf_inher\n";
-       class_type i ppf ct;
--  | Pctf_val (s, mf, cto, loc) ->
-+  | Pctf_val (s, mf, vf, ct, loc) ->
-       line i ppf
--        "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
--      option i core_type ppf cto;
-+        "Pctf_val \"%s\" %a %a %a\n" s
-+        fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc;
-+      core_type (i+1) ppf ct;
-   | Pctf_virt (s, pf, ct, loc) ->
-       line i ppf
-         "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
-@@ -428,6 +429,10 @@
-       line i ppf "Pcf_inher\n";
-       class_expr (i+1) ppf ce;
-       option (i+1) string ppf so;
-+  | Pcf_valvirt (s, mf, ct, loc) ->
-+      line i ppf
-+        "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-+      core_type (i+1) ppf ct;
-   | Pcf_val (s, mf, e, loc) ->
-       line i ppf
-         "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-Index: typing/btype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
-retrieving revision 1.38
-diff -u -r1.38 btype.ml
---- typing/btype.ml    4 Jan 2006 16:55:50 -0000       1.38
-+++ typing/btype.ml    5 Apr 2006 02:25:59 -0000
-@@ -330,7 +330,7 @@
- 
- let unmark_class_signature sign =
-   unmark_type sign.cty_self;
--  Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars
-+  Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars
- 
- let rec unmark_class_type =
-   function
-Index: typing/ctype.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
-retrieving revision 1.200
-diff -u -r1.200 ctype.ml
---- typing/ctype.ml    6 Jan 2006 02:16:24 -0000       1.200
-+++ typing/ctype.ml    5 Apr 2006 02:25:59 -0000
-@@ -857,7 +857,7 @@
-         Tcty_signature
-           {cty_self = copy sign.cty_self;
-            cty_vars =
--             Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
-+             Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars;
-            cty_concr = sign.cty_concr;
-            cty_inher =
-              List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
-@@ -2354,10 +2354,11 @@
-   | CM_Val_type_mismatch of string * (type_expr * type_expr) list
-   | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
-   | CM_Non_mutable_value of string
-+  | CM_Non_concrete_value of string
-   | CM_Missing_value of string
-   | CM_Missing_method of string
-   | CM_Hide_public of string
--  | CM_Hide_virtual of string
-+  | CM_Hide_virtual of string * string
-   | CM_Public_method of string
-   | CM_Private_method of string
-   | CM_Virtual_method of string
-@@ -2390,8 +2391,8 @@
-            end)
-         pairs;
-       Vars.iter
--        (fun lab (mut, ty) ->
--           let (mut', ty') = Vars.find lab sign1.cty_vars in
-+        (fun lab (mut, v, ty) ->
-+           let (mut', v', ty') = Vars.find lab sign1.cty_vars in
-            try moregen true type_pairs env ty' ty with Unify trace ->
-              raise (Failure [CM_Val_type_mismatch
-                                 (lab, expand_trace env trace)]))
-@@ -2437,7 +2438,7 @@
-              end
-            in
-            if Concr.mem lab sign1.cty_concr then err
--           else CM_Hide_virtual lab::err)
-+           else CM_Hide_virtual ("method", lab) :: err)
-         miss1 []
-     in
-     let missing_method = List.map (fun (m, _, _) -> m) miss2 in
-@@ -2455,11 +2456,13 @@
-     in
-     let error =
-       Vars.fold
--        (fun lab (mut, ty) err ->
-+        (fun lab (mut, vr, ty) err ->
-           try
--            let (mut', ty') = Vars.find lab sign1.cty_vars in
-+            let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
-             if mut = Mutable && mut' <> Mutable then
-               CM_Non_mutable_value lab::err
-+            else if vr = Concrete && vr' <> Concrete then
-+              CM_Non_concrete_value lab::err
-             else
-               err
-           with Not_found ->
-@@ -2467,6 +2470,14 @@
-         sign2.cty_vars error
-     in
-     let error =
-+      Vars.fold
-+        (fun lab (_,vr,_) err ->
-+          if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
-+            CM_Hide_virtual ("instance variable", lab) :: err
-+          else err)
-+        sign1.cty_vars error
-+    in
-+    let error =
-       List.fold_right
-         (fun e l ->
-            if List.mem e missing_method then l else CM_Virtual_method e::l)
-@@ -2516,8 +2527,8 @@
-              end)
-           pairs;
-         Vars.iter
--          (fun lab (mut, ty) ->
--             let (mut', ty') = Vars.find lab sign1.cty_vars in
-+          (fun lab (_, _, ty) ->
-+             let (_, _, ty') = Vars.find lab sign1.cty_vars in
-              try eqtype true type_pairs subst env ty ty' with Unify trace ->
-                raise (Failure [CM_Val_type_mismatch
-                                   (lab, expand_trace env trace)]))
-@@ -2554,7 +2565,7 @@
-           end
-         in
-         if Concr.mem lab sign1.cty_concr then err
--        else CM_Hide_virtual lab::err)
-+        else CM_Hide_virtual ("method", lab) :: err)
-       miss1 []
-   in
-   let missing_method = List.map (fun (m, _, _) -> m) miss2 in
-@@ -2578,11 +2589,13 @@
-   in
-   let error =
-     Vars.fold
--      (fun lab (mut, ty) err ->
-+      (fun lab (mut, vr, ty) err ->
-          try
--           let (mut', ty') = Vars.find lab sign1.cty_vars in
-+           let (mut', vr', ty') = Vars.find lab sign1.cty_vars in
-            if mut = Mutable && mut' <> Mutable then
-              CM_Non_mutable_value lab::err
-+           else if vr = Concrete && vr' <> Concrete then
-+             CM_Non_concrete_value lab::err
-            else
-              err
-          with Not_found ->
-@@ -2590,6 +2603,14 @@
-       sign2.cty_vars error
-   in
-   let error =
-+    Vars.fold
-+      (fun lab (_,vr,_) err ->
-+        if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then
-+          CM_Hide_virtual ("instance variable", lab) :: err
-+        else err)
-+      sign1.cty_vars error
-+  in
-+  let error =
-     List.fold_right
-       (fun e l ->
-         if List.mem e missing_method then l else CM_Virtual_method e::l)
-@@ -3279,7 +3300,7 @@
- let nondep_class_signature env id sign =
-   { cty_self = nondep_type_rec env id sign.cty_self;
-     cty_vars =
--      Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
-+      Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t))
-         sign.cty_vars;
-     cty_concr = sign.cty_concr;
-     cty_inher =
-Index: typing/ctype.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
-retrieving revision 1.53
-diff -u -r1.53 ctype.mli
---- typing/ctype.mli   9 Dec 2004 12:40:53 -0000       1.53
-+++ typing/ctype.mli   5 Apr 2006 02:25:59 -0000
-@@ -170,10 +170,11 @@
-   | CM_Val_type_mismatch of string * (type_expr * type_expr) list
-   | CM_Meth_type_mismatch of string * (type_expr * type_expr) list
-   | CM_Non_mutable_value of string
-+  | CM_Non_concrete_value of string
-   | CM_Missing_value of string
-   | CM_Missing_method of string
-   | CM_Hide_public of string
--  | CM_Hide_virtual of string
-+  | CM_Hide_virtual of string * string
-   | CM_Public_method of string
-   | CM_Private_method of string
-   | CM_Virtual_method of string
-Index: typing/includeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/includeclass.ml,v
-retrieving revision 1.7
-diff -u -r1.7 includeclass.ml
---- typing/includeclass.ml     6 Mar 2000 22:11:57 -0000       1.7
-+++ typing/includeclass.ml     5 Apr 2006 02:25:59 -0000
-@@ -78,14 +78,17 @@
-   | CM_Non_mutable_value lab ->
-       fprintf ppf
-        "@[The non-mutable instance variable %s cannot become mutable@]" lab
-+  | CM_Non_concrete_value lab ->
-+      fprintf ppf
-+       "@[The virtual instance variable %s cannot become concrete@]" lab
-   | CM_Missing_value lab ->
-       fprintf ppf "@[The first class type has no instance variable %s@]" lab
-   | CM_Missing_method lab ->
-       fprintf ppf "@[The first class type has no method %s@]" lab
-   | CM_Hide_public lab ->
-      fprintf ppf "@[The public method %s cannot be hidden@]" lab
--  | CM_Hide_virtual lab ->
--      fprintf ppf "@[The virtual method %s cannot be hidden@]" lab
-+  | CM_Hide_virtual (k, lab) ->
-+      fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab
-   | CM_Public_method lab ->
-       fprintf ppf "@[The public method %s cannot become private" lab
-   | CM_Virtual_method lab ->
-Index: typing/oprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
-retrieving revision 1.22
-diff -u -r1.22 oprint.ml
---- typing/oprint.ml   23 Mar 2005 03:08:37 -0000      1.22
-+++ typing/oprint.ml   5 Apr 2006 02:25:59 -0000
-@@ -291,8 +291,10 @@
-       fprintf ppf "@[<2>method %s%s%s :@ %a@]"
-         (if priv then "private " else "") (if virt then "virtual " else "")
-         name !out_type ty
--  | Ocsg_value (name, mut, ty) ->
--      fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "")
-+  | Ocsg_value (name, mut, vr, ty) ->
-+      fprintf ppf "@[<2>val %s%s%s :@ %a@]"
-+        (if mut then "mutable " else "")
-+        (if vr then "virtual " else "")
-         name !out_type ty
- 
- let out_class_type = ref print_out_class_type
-Index: typing/outcometree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
-retrieving revision 1.14
-diff -u -r1.14 outcometree.mli
---- typing/outcometree.mli     23 Mar 2005 03:08:37 -0000      1.14
-+++ typing/outcometree.mli     5 Apr 2006 02:25:59 -0000
-@@ -71,7 +71,7 @@
- and out_class_sig_item =
-   | Ocsg_constraint of out_type * out_type
-   | Ocsg_method of string * bool * bool * out_type
--  | Ocsg_value of string * bool * out_type
-+  | Ocsg_value of string * bool * bool * out_type
- 
- type out_module_type =
-   | Omty_abstract
-Index: typing/printtyp.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
-retrieving revision 1.140
-diff -u -r1.140 printtyp.ml
---- typing/printtyp.ml 4 Jan 2006 16:55:50 -0000       1.140
-+++ typing/printtyp.ml 5 Apr 2006 02:26:00 -0000
-@@ -650,7 +650,7 @@
-         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
-       in
-       List.iter (fun met -> mark_loops (method_type met)) fields;
--      Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
-+      Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
-   | Tcty_fun (_, ty, cty) ->
-       mark_loops ty;
-       prepare_class_type params cty
-@@ -682,13 +682,15 @@
-           csil (tree_of_constraints params)
-       in
-       let all_vars =
--        Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in
-+        Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars []
-+      in
-       (* Consequence of PR#3607: order of Map.fold has changed! *)
-       let all_vars = List.rev all_vars in
-       let csil =
-         List.fold_left
--          (fun csil (l, m, t) ->
--             Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil)
-+          (fun csil (l, m, v, t) ->
-+            Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
-+            :: csil)
-           csil all_vars
-       in
-       let csil =
-@@ -763,7 +765,9 @@
-     List.exists
-       (fun (lab, _, ty) ->
-          not (lab = dummy_method || Concr.mem lab sign.cty_concr))
--      fields in
-+      fields
-+    || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false
-+  in
- 
-   Osig_class_type
-     (virt, Ident.name id,
-Index: typing/subst.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/subst.ml,v
-retrieving revision 1.49
-diff -u -r1.49 subst.ml
---- typing/subst.ml    4 Jan 2006 16:55:50 -0000       1.49
-+++ typing/subst.ml    5 Apr 2006 02:26:00 -0000
-@@ -178,7 +178,8 @@
- 
- let class_signature s sign =
-   { cty_self = typexp s sign.cty_self;
--    cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
-+    cty_vars =
-+      Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars;
-     cty_concr = sign.cty_concr;
-     cty_inher =
-       List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
-Index: typing/typeclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.ml,v
-retrieving revision 1.85
-diff -u -r1.85 typeclass.ml
---- typing/typeclass.ml        22 Jul 2005 06:42:36 -0000      1.85
-+++ typing/typeclass.ml        5 Apr 2006 02:26:00 -0000
-@@ -24,7 +24,7 @@
- 
- type error =
-     Unconsistent_constraint of (type_expr * type_expr) list
--  | Method_type_mismatch of string * (type_expr * type_expr) list
-+  | Field_type_mismatch of string * string * (type_expr * type_expr) list
-   | Structure_expected of class_type
-   | Cannot_apply of class_type
-   | Apply_wrong_label of label
-@@ -36,7 +36,7 @@
-   | Unbound_class_type_2 of Longident.t
-   | Abbrev_type_clash of type_expr * type_expr * type_expr
-   | Constructor_type_mismatch of string * (type_expr * type_expr) list
--  | Virtual_class of bool * string list
-+  | Virtual_class of bool * string list * string list
-   | Parameter_arity_mismatch of Longident.t * int * int
-   | Parameter_mismatch of (type_expr * type_expr) list
-   | Bad_parameters of Ident.t * type_expr * type_expr
-@@ -49,6 +49,7 @@
-   | Non_collapsable_conjunction of
-       Ident.t * Types.class_declaration * (type_expr * type_expr) list
-   | Final_self_clash of (type_expr * type_expr) list
-+  | Mutability_mismatch of string * mutable_flag
- 
- exception Error of Location.t * error
- 
-@@ -90,7 +91,7 @@
-       generalize_class_type cty
-   | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
-       Ctype.generalize sty;
--      Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
-+      Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars;
-       List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
-   | Tcty_fun (_, ty, cty) ->
-       Ctype.generalize ty;
-@@ -152,7 +153,7 @@
-   | Tcty_signature sign ->
-       Ctype.closed_schema sign.cty_self
-         &&
--      Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc)
-+      Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc)
-         sign.cty_vars
-         true
-   | Tcty_fun (_, ty, cty) ->
-@@ -172,7 +173,7 @@
-       limited_generalize rv cty
-   | Tcty_signature sign ->
-       Ctype.limited_generalize rv sign.cty_self;
--      Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
-+      Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty)
-         sign.cty_vars;
-       List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
-         sign.cty_inher
-@@ -201,11 +202,25 @@
-    Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
- 
- (* Enter an instance variable in the environment *)
--let enter_val cl_num vars lab mut ty val_env met_env par_env =
--  let (id, val_env, met_env, par_env) as result =
--    enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
-+let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
-+  let (id, virt) =
-+    try
-+      let (id, mut', virt', ty') = Vars.find lab !vars in
-+      if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
-+      Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
-+      (if not inh then Some id else None),
-+      (if virt' = Concrete then virt' else virt)
-+    with
-+      Ctype.Unify tr ->
-+        raise (Error(loc, Field_type_mismatch("instance variable", lab, tr)))
-+    | Not_found -> None, virt
-+  in
-+  let (id, _, _, _) as result =
-+    match id with Some id -> (id, val_env, met_env, par_env)
-+    | None ->
-+        enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
-   in
--  vars := Vars.add lab (id, mut, ty) !vars;
-+  vars := Vars.add lab (id, mut, virt, ty) !vars;
-   result
- 
- let inheritance self_type env concr_meths warn_meths loc parent =
-@@ -218,7 +233,7 @@
-       with Ctype.Unify trace ->
-         match trace with
-           _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
--            raise(Error(loc, Method_type_mismatch (n, rem)))
-+            raise(Error(loc, Field_type_mismatch ("method", n, rem)))
-         | _ ->
-             assert false
-       end;
-@@ -243,7 +258,7 @@
-   in
-   let ty = transl_simple_type val_env false sty in
-   try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
--    raise(Error(loc, Method_type_mismatch (lab, trace)))
-+    raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
- 
- let delayed_meth_specs = ref []
- 
-@@ -253,7 +268,7 @@
-   in
-   let unif ty =
-     try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
--      raise(Error(loc, Method_type_mismatch (lab, trace)))
-+      raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
-   in
-   match sty.ptyp_desc, priv with
-     Ptyp_poly ([],sty), Public ->
-@@ -279,6 +294,15 @@
- 
- (*******************************)
- 
-+let add_val env loc lab (mut, virt, ty) val_sig = 
-+  let virt =
-+    try
-+      let (mut', virt', ty') = Vars.find lab val_sig in
-+      if virt' = Concrete then virt' else virt
-+    with Not_found -> virt
-+  in
-+  Vars.add lab (mut, virt, ty) val_sig
-+
- let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
-   function
-     Pctf_inher sparent ->
-@@ -293,25 +317,12 @@
-           parent
-       in
-       let val_sig =
--        Vars.fold
--          (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
--          cl_sig.cty_vars val_sig
--      in
-+        Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in
-       (val_sig, concr_meths, inher)
- 
--  | Pctf_val (lab, mut, sty_opt, loc) ->
--      let (mut, ty) =
--        match sty_opt with
--          None     ->
--            let (mut', ty) =
--              try Vars.find lab val_sig with Not_found ->
--                raise(Error(loc, Unbound_val lab))
--            in
--            (if mut = Mutable then mut' else Immutable), ty
--        | Some sty ->
--            mut, transl_simple_type env false sty
--      in
--      (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
-+  | Pctf_val (lab, mut, virt, sty, loc) ->
-+      let ty = transl_simple_type env false sty in
-+      (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher)
- 
-   | Pctf_virt (lab, priv, sty, loc) ->
-       declare_method env meths self_type lab priv sty loc;
-@@ -397,7 +408,7 @@
- 
- let rec class_field cl_num self_type meths vars
-     (val_env, met_env, par_env, fields, concr_meths, warn_meths,
--     inh_vals, inher) =
-+     warn_vals, inher) =
-   function
-     Pcf_inher (sparent, super) ->
-       let parent = class_expr cl_num val_env par_env sparent in
-@@ -411,18 +422,23 @@
-           parent.cl_type
-       in
-       (* Variables *)
--      let (val_env, met_env, par_env, inh_vars, inh_vals) =
-+      let (val_env, met_env, par_env, inh_vars, warn_vals) =
-         Vars.fold
--          (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) ->
-+          (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) ->
-+             let mut, vr, ty = info in
-              let (id, val_env, met_env, par_env) =
--               enter_val cl_num vars lab mut ty val_env met_env par_env
-+               enter_val cl_num vars true lab mut vr ty val_env met_env par_env
-+                 sparent.pcl_loc
-              in
--             if StringSet.mem lab inh_vals then
--               Location.prerr_warning sparent.pcl_loc
--                 (Warnings.Hide_instance_variable lab);
--             (val_env, met_env, par_env, (lab, id) :: inh_vars,
--              StringSet.add lab inh_vals))
--          cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals)
-+             let warn_vals =
-+               if vr = Virtual then warn_vals else
-+               if StringSet.mem lab warn_vals then
-+                 (Location.prerr_warning sparent.pcl_loc
-+                   (Warnings.Instance_variable_override lab); warn_vals)
-+               else StringSet.add lab warn_vals
-+             in
-+             (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals))
-+          cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals)
-       in
-       (* Inherited concrete methods *)
-       let inh_meths = 
-@@ -443,11 +459,26 @@
-       in
-       (val_env, met_env, par_env,
-        lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
--       concr_meths, warn_meths, inh_vals, inher)
-+       concr_meths, warn_meths, warn_vals, inher)
-+
-+  | Pcf_valvirt (lab, mut, styp, loc) ->
-+      if !Clflags.principal then Ctype.begin_def ();
-+      let ty = Typetexp.transl_simple_type val_env false styp in
-+      if !Clflags.principal then begin
-+        Ctype.end_def ();
-+        Ctype.generalize_structure ty
-+      end;
-+      let (id, val_env, met_env', par_env) =
-+        enter_val cl_num vars false lab mut Virtual ty
-+          val_env met_env par_env loc
-+      in
-+      (val_env, met_env', par_env,
-+       lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields,
-+       concr_meths, warn_meths, StringSet.remove lab warn_vals, inher)
- 
-   | Pcf_val (lab, mut, sexp, loc) ->
--      if StringSet.mem lab inh_vals then
--        Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
-+      if StringSet.mem lab warn_vals then
-+        Location.prerr_warning loc (Warnings.Instance_variable_override lab);
-       if !Clflags.principal then Ctype.begin_def ();
-       let exp =
-         try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
-@@ -457,17 +488,19 @@
-         Ctype.end_def ();
-         Ctype.generalize_structure exp.exp_type
-       end;
--      let (id, val_env, met_env, par_env) =
--        enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
--      in
--      (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
--       concr_meths, warn_meths, inh_vals, inher)
-+      let (id, val_env, met_env', par_env) =
-+        enter_val cl_num vars false lab mut Concrete exp.exp_type
-+          val_env met_env par_env loc
-+      in
-+      (val_env, met_env', par_env,
-+       lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields,
-+       concr_meths, warn_meths, StringSet.add lab warn_vals, inher)
- 
-   | Pcf_virt (lab, priv, sty, loc) ->
-       virtual_method val_env meths self_type lab priv sty loc;
-       let warn_meths = Concr.remove lab warn_meths in
-       (val_env, met_env, par_env, fields, concr_meths, warn_meths,
--       inh_vals, inher)
-+       warn_vals, inher)
- 
-   | Pcf_meth (lab, priv, expr, loc)  ->
-       let (_, ty) =
-@@ -493,7 +526,7 @@
-           end
-       | _ -> assert false
-       with Ctype.Unify trace ->
--        raise(Error(loc, Method_type_mismatch (lab, trace)))
-+        raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
-       end;
-       let meth_expr = make_method cl_num expr in
-       (* backup variables for Pexp_override *)
-@@ -510,12 +543,12 @@
-           Cf_meth (lab, texp)
-         end in
-       (val_env, met_env, par_env, field::fields,
--       Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
-+       Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher)
- 
-   | Pcf_cstr (sty, sty', loc) ->
-       type_constraint val_env sty sty' loc;
-       (val_env, met_env, par_env, fields, concr_meths, warn_meths,
--       inh_vals, inher)
-+       warn_vals, inher)
- 
-   | Pcf_let (rec_flag, sdefs, loc) ->
-       let (defs, val_env) =
-@@ -545,7 +578,7 @@
-           ([], met_env, par_env)
-       in
-       (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
--       concr_meths, warn_meths, inh_vals, inher)
-+       concr_meths, warn_meths, warn_vals, inher)
- 
-   | Pcf_init expr ->
-       let expr = make_method cl_num expr in
-@@ -562,7 +595,7 @@
-           Cf_init texp
-         end in
-       (val_env, met_env, par_env, field::fields,
--       concr_meths, warn_meths, inh_vals, inher)
-+       concr_meths, warn_meths, warn_vals, inher)
- 
- and class_structure cl_num final val_env met_env loc (spat, str) =
-   (* Environment for substructures *)
-@@ -616,7 +649,7 @@
-   Ctype.unify val_env self_type (Ctype.newvar ());
-   let sign =
-     {cty_self = public_self;
--     cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
-+     cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars;
-      cty_concr = concr_meths;
-      cty_inher = inher} in
-   let methods = get_methods self_type in
-@@ -628,7 +661,11 @@
-        be modified after this point *)
-     Ctype.close_object self_type;
-     let mets = virtual_methods {sign with cty_self = self_type} in
--    if mets <> [] then raise(Error(loc, Virtual_class(true, mets)));
-+    let vals =
-+      Vars.fold
-+        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
-+        sign.cty_vars [] in
-+    if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals)));
-     let self_methods =
-       List.fold_right
-         (fun (lab,kind,ty) rem ->
-@@ -1135,9 +1172,14 @@
-   in
- 
-   if cl.pci_virt = Concrete then begin
--    match virtual_methods (Ctype.signature_of_class_type typ) with
--      []   -> ()
--    | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets)))
-+    let sign = Ctype.signature_of_class_type typ in
-+    let mets = virtual_methods sign in
-+    let vals =
-+      Vars.fold
-+        (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
-+        sign.cty_vars [] in
-+    if mets <> []  || vals <> [] then
-+      raise(Error(cl.pci_loc, Virtual_class(true, mets, vals)));
-   end;
- 
-   (* Misc. *)
-@@ -1400,10 +1442,10 @@
-       Printtyp.report_unification_error ppf trace
-         (fun ppf -> fprintf ppf "Type")
-         (fun ppf -> fprintf ppf "is not compatible with type")
--  | Method_type_mismatch (m, trace) ->
-+  | Field_type_mismatch (k, m, trace) ->
-       Printtyp.report_unification_error ppf trace
-         (function ppf ->
--           fprintf ppf "The method %s@ has type" m)
-+           fprintf ppf "The %s %s@ has type" k m)
-         (function ppf ->
-            fprintf ppf "but is expected to have type")
-   | Structure_expected clty ->
-@@ -1451,15 +1493,20 @@
-            fprintf ppf "The expression \"new %s\" has type" c)
-         (function ppf ->
-            fprintf ppf "but is used with type")
--  | Virtual_class (cl, mets) ->
-+  | Virtual_class (cl, mets, vals) ->
-       let print_mets ppf mets =
-         List.iter (function met -> fprintf ppf "@ %s" met) mets in
-       let cl_mark = if cl then "" else " type" in
-+      let missings =
-+        match mets, vals with
-+          [], _ -> "variables"
-+        | _, [] -> "methods"
-+        | _ -> "methods and variables"
-+      in
-       fprintf ppf
--        "@[This class%s should be virtual@ \
--           @[<2>The following methods are undefined :%a@]
--         @]"
--        cl_mark print_mets mets
-+        "@[This class%s should be virtual.@ \
-+           @[<2>The following %s are undefined :%a@]@]"
-+          cl_mark missings print_mets (mets @ vals)
-   | Parameter_arity_mismatch(lid, expected, provided) ->
-       fprintf ppf
-         "@[The class constructor %a@ expects %i type argument(s),@ \
-@@ -1532,3 +1579,10 @@
-            fprintf ppf "This object is expected to have type")
-         (function ppf ->
-            fprintf ppf "but has actually type")
-+  | Mutability_mismatch (lab, mut) ->
-+      let mut1, mut2 =
-+        if mut = Immutable then "mutable", "immutable"
-+        else "immutable", "mutable" in
-+      fprintf ppf
-+        "@[The instance variable is %s,@ it cannot be redefined as %s@]"
-+        mut1 mut2
-Index: typing/typeclass.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typeclass.mli,v
-retrieving revision 1.18
-diff -u -r1.18 typeclass.mli
---- typing/typeclass.mli       1 Dec 2003 00:32:11 -0000       1.18
-+++ typing/typeclass.mli       5 Apr 2006 02:26:00 -0000
-@@ -49,7 +49,7 @@
- 
- type error =
-     Unconsistent_constraint of (type_expr * type_expr) list
--  | Method_type_mismatch of string * (type_expr * type_expr) list
-+  | Field_type_mismatch of string * string * (type_expr * type_expr) list
-   | Structure_expected of class_type
-   | Cannot_apply of class_type
-   | Apply_wrong_label of label
-@@ -61,7 +61,7 @@
-   | Unbound_class_type_2 of Longident.t
-   | Abbrev_type_clash of type_expr * type_expr * type_expr
-   | Constructor_type_mismatch of string * (type_expr * type_expr) list
--  | Virtual_class of bool * string list
-+  | Virtual_class of bool * string list * string list
-   | Parameter_arity_mismatch of Longident.t * int * int
-   | Parameter_mismatch of (type_expr * type_expr) list
-   | Bad_parameters of Ident.t * type_expr * type_expr
-@@ -74,6 +74,7 @@
-   | Non_collapsable_conjunction of
-       Ident.t * Types.class_declaration * (type_expr * type_expr) list
-   | Final_self_clash of (type_expr * type_expr) list
-+  | Mutability_mismatch of string * mutable_flag
- 
- exception Error of Location.t * error
- 
-Index: typing/typecore.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
-retrieving revision 1.178
-diff -u -r1.178 typecore.ml
---- typing/typecore.ml 6 Jan 2006 02:25:37 -0000       1.178
-+++ typing/typecore.ml 5 Apr 2006 02:26:00 -0000
-@@ -611,11 +611,11 @@
-       List.for_all
-         (function
-             Cf_meth _ -> true
--          | Cf_val (_,_,e) -> incr count; is_nonexpansive e
-+          | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
-           | Cf_init e -> is_nonexpansive e
-           | Cf_inher _ | Cf_let _ -> false)
-         fields &&
--      Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable)
-+      Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
-         vars true &&
-       !count = 0
-   | _ -> false
-@@ -1356,7 +1356,7 @@
-         (path_self, _) ->
-           let type_override (lab, snewval) =
-             begin try
--              let (id, _, ty) = Vars.find lab !vars in
-+              let (id, _, _, ty) = Vars.find lab !vars in
-               (Path.Pident id, type_expect env snewval (instance ty))
-             with
-               Not_found ->
-Index: typing/typecore.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.mli,v
-retrieving revision 1.37
-diff -u -r1.37 typecore.mli
---- typing/typecore.mli        4 Mar 2005 14:51:31 -0000       1.37
-+++ typing/typecore.mli        5 Apr 2006 02:26:00 -0000
-@@ -38,7 +38,8 @@
-         string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern ->
-         Typedtree.pattern *
-         (Ident.t * type_expr) Meths.t ref *
--        (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+        (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr)
-+            Vars.t ref *
-         Env.t * Env.t * Env.t
- val type_expect:
-         ?in_function:(Location.t * type_expr) ->
-Index: typing/typedtree.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.ml,v
-retrieving revision 1.36
-diff -u -r1.36 typedtree.ml
---- typing/typedtree.ml        25 Nov 2003 09:20:43 -0000      1.36
-+++ typing/typedtree.ml        5 Apr 2006 02:26:00 -0000
-@@ -106,7 +106,7 @@
- 
- and class_field =
-     Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
--  | Cf_val of string * Ident.t * expression
-+  | Cf_val of string * Ident.t * expression option * bool
-   | Cf_meth of string * expression
-   | Cf_let of rec_flag * (pattern * expression) list *
-               (Ident.t * expression) list
-@@ -140,7 +140,8 @@
-   | Tstr_recmodule of (Ident.t * module_expr) list
-   | Tstr_modtype of Ident.t * module_type
-   | Tstr_open of Path.t
--  | Tstr_class of (Ident.t * int * string list * class_expr) list
-+  | Tstr_class of
-+      (Ident.t * int * string list * class_expr * virtual_flag) list
-   | Tstr_cltype of (Ident.t * cltype_declaration) list
-   | Tstr_include of module_expr * Ident.t list
- 
-Index: typing/typedtree.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typedtree.mli,v
-retrieving revision 1.34
-diff -u -r1.34 typedtree.mli
---- typing/typedtree.mli       25 Nov 2003 09:20:43 -0000      1.34
-+++ typing/typedtree.mli       5 Apr 2006 02:26:00 -0000
-@@ -107,7 +107,8 @@
- and class_field =
-     Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
-     (* Inherited instance variables and concrete methods *)
--  | Cf_val of string * Ident.t * expression
-+  | Cf_val of string * Ident.t * expression option * bool
-+        (* None = virtual, true = override *)
-   | Cf_meth of string * expression
-   | Cf_let of rec_flag * (pattern * expression) list *
-               (Ident.t * expression) list
-@@ -141,7 +142,8 @@
-   | Tstr_recmodule of (Ident.t * module_expr) list
-   | Tstr_modtype of Ident.t * module_type
-   | Tstr_open of Path.t
--  | Tstr_class of (Ident.t * int * string list * class_expr) list
-+  | Tstr_class of
-+      (Ident.t * int * string list * class_expr * virtual_flag) list
-   | Tstr_cltype of (Ident.t * cltype_declaration) list
-   | Tstr_include of module_expr * Ident.t list
- 
-Index: typing/typemod.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/typemod.ml,v
-retrieving revision 1.73
-diff -u -r1.73 typemod.ml
---- typing/typemod.ml  8 Aug 2005 09:41:51 -0000       1.73
-+++ typing/typemod.ml  5 Apr 2006 02:26:00 -0000
-@@ -17,6 +17,7 @@
- open Misc
- open Longident
- open Path
-+open Asttypes
- open Parsetree
- open Types
- open Typedtree
-@@ -667,8 +668,9 @@
-         let (classes, new_env) = Typeclass.class_declarations env cl in
-         let (str_rem, sig_rem, final_env) = type_struct new_env srem in
-         (Tstr_class
--           (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) ->
--              (i, s, m, c)) classes) ::
-+           (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) ->
-+              let vf = if d.cty_new = None then Virtual else Concrete in
-+              (i, s, m, c, vf)) classes) ::
-          Tstr_cltype
-            (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) ::
-          Tstr_type
-Index: typing/types.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
-retrieving revision 1.25
-diff -u -r1.25 types.ml
---- typing/types.ml    9 Dec 2004 12:40:53 -0000       1.25
-+++ typing/types.ml    5 Apr 2006 02:26:00 -0000
-@@ -90,7 +90,8 @@
-   | Val_prim of Primitive.description   (* Primitive *)
-   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
-   | Val_self of (Ident.t * type_expr) Meths.t ref *
--                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+                (Ident.t * Asttypes.mutable_flag *
-+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
-                 string * type_expr
-                                         (* Self *)
-   | Val_anc of (string * Ident.t) list * string
-@@ -156,7 +157,8 @@
- 
- and class_signature =
-   { cty_self: type_expr;
--    cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-+    cty_vars:
-+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
-     cty_concr: Concr.t;
-     cty_inher: (Path.t * type_expr list) list }
- 
-Index: typing/types.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
-retrieving revision 1.25
-diff -u -r1.25 types.mli
---- typing/types.mli   9 Dec 2004 12:40:53 -0000       1.25
-+++ typing/types.mli   5 Apr 2006 02:26:00 -0000
-@@ -91,7 +91,8 @@
-   | Val_prim of Primitive.description   (* Primitive *)
-   | Val_ivar of mutable_flag * string   (* Instance variable (mutable ?) *)
-   | Val_self of (Ident.t * type_expr) Meths.t ref *
--                (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref *
-+                (Ident.t * Asttypes.mutable_flag *
-+                 Asttypes.virtual_flag * type_expr) Vars.t ref *
-                 string * type_expr
-                                         (* Self *)
-   | Val_anc of (string * Ident.t) list * string
-@@ -158,7 +159,8 @@
- 
- and class_signature =
-   { cty_self: type_expr;
--    cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
-+    cty_vars:
-+      (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t;
-     cty_concr: Concr.t;
-     cty_inher: (Path.t * type_expr list) list }
- 
-Index: typing/unused_var.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/typing/unused_var.ml,v
-retrieving revision 1.5
-diff -u -r1.5 unused_var.ml
---- typing/unused_var.ml       4 Jan 2006 16:55:50 -0000       1.5
-+++ typing/unused_var.ml       5 Apr 2006 02:26:00 -0000
-@@ -245,7 +245,7 @@
-   match cf with
-   | Pcf_inher (ce, _) -> class_expr ppf tbl ce;
-   | Pcf_val (_, _, e, _) -> expression ppf tbl e;
--  | Pcf_virt _ -> ()
-+  | Pcf_virt _ | Pcf_valvirt _ -> ()
-   | Pcf_meth (_, _, e, _) -> expression ppf tbl e;
-   | Pcf_cstr _ -> ()
-   | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
-Index: bytecomp/translclass.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
-retrieving revision 1.38
-diff -u -r1.38 translclass.ml
---- bytecomp/translclass.ml    13 Aug 2005 20:59:37 -0000      1.38
-+++ bytecomp/translclass.ml    5 Apr 2006 02:26:00 -0000
-@@ -133,10 +133,10 @@
-                        (fun _ -> lambda_unit) cl
-                    in
-                    (inh_init, lsequence obj_init' obj_init, true)
--               | Cf_val (_, id, exp) ->
-+               | Cf_val (_, id, Some exp, _) ->
-                    (inh_init, lsequence (set_inst_var obj id exp) obj_init,
-                     has_init)
--               | Cf_meth _ ->
-+               | Cf_meth _ | Cf_val _ ->
-                    (inh_init, obj_init, has_init)
-                | Cf_init _ ->
-                    (inh_init, obj_init, true)
-@@ -213,27 +213,17 @@
-   if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
-   if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
-   let ids = Ident.create "ids" in
--  let i = ref len in
--  let getter, names, cl_init =
--    match vals with [] -> "get_method_labels", [], cl_init
--    | (_,id0)::vals' ->
--        incr i;
--        let i = ref (List.length vals) in
--        "new_methods_variables",
--        [transl_meth_list (List.map fst vals)],
--        Llet(Strict, id0, lfield ids 0,
--           List.fold_right
--             (fun (name,id) rem ->
--               decr i;
--                 Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem))
--             vals' cl_init)
-+  let i = ref (len + nvals) in
-+  let getter, names =
-+    if nvals = 0 then "get_method_labels", [] else
-+    "new_methods_variables", [transl_meth_list (List.map fst vals)]
-   in
-   Llet(StrictOpt, ids,
-        Lapply (oo_prim getter,
-                [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
-        List.fold_right
-          (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
--         methl cl_init)
-+         (methl @ vals) cl_init)
- 
- let output_methods tbl methods lam =
-   match methods with
-@@ -283,8 +273,9 @@
-                     (vals, meths_super cla str.cl_meths meths)
-                     inh_init cl_init msubst top cl in
-                 (inh_init, cl_init, [], values)
--            | Cf_val (name, id, exp) ->
--                (inh_init, cl_init, methods, (name, id)::values)
-+            | Cf_val (name, id, exp, over) ->
-+                let values = if over then values else (name, id) :: values in
-+                (inh_init, cl_init, methods, values)
-             | Cf_meth (name, exp) ->
-                 let met_code = msubst true (transl_exp exp) in
-                 let met_code =
-@@ -342,27 +333,24 @@
-         assert (Path.same path path');
-         let lpath = transl_path path in
-           let inh = Ident.create "inh"
--          and inh_vals = Ident.create "vals"
--          and inh_meths = Ident.create "meths"
-+          and ofs = List.length vals + 1
-           and valids, methids = super in
-           let cl_init =
-             List.fold_left
-               (fun init (nm, id, _) ->
--                Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths),
-+                Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs),
-                      init))
-               cl_init methids in
-           let cl_init =
-             List.fold_left
-               (fun init (nm, id) ->
--                Llet(StrictOpt, id, lfield inh_vals (index nm vals), init))
-+                Llet(StrictOpt, id, lfield inh (index nm vals + 1), init))
-               cl_init valids in
-           (inh_init,
-            Llet (Strict, inh, 
-                Lapply(oo_prim "inherits", narrow_args @
-                       [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
--                 Llet(StrictOpt, obj_init, lfield inh 0,
--                 Llet(Alias, inh_vals, lfield inh 1,
--                 Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
-+                 Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
-       | _ ->
-         let core cl_init =
-             build_class_init cla true super inh_init cl_init msubst top cl
-@@ -397,12 +385,16 @@
-    XXX Il devrait etre peu couteux d'ecrire des classes :
-      class c x y = d e f
- *)
--let rec transl_class_rebind obj_init cl =
-+let rec transl_class_rebind obj_init cl vf =
-   match cl.cl_desc with
-     Tclass_ident path ->
-+      if vf = Concrete then begin
-+        try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
-+        with Not_found -> raise Exit
-+      end;
-       (path, obj_init)
-   | Tclass_fun (pat, _, cl, partial) ->
--      let path, obj_init = transl_class_rebind obj_init cl in
-+      let path, obj_init = transl_class_rebind obj_init cl vf in
-       let build params rem =
-         let param = name_pattern "param" [pat, ()] in
-         Lfunction (Curried, param::params,
-@@ -414,14 +406,14 @@
-          Lfunction (Curried, params, rem) -> build params rem
-        | rem                              -> build [] rem)
-   | Tclass_apply (cl, oexprs) ->
--      let path, obj_init = transl_class_rebind obj_init cl in
-+      let path, obj_init = transl_class_rebind obj_init cl vf in
-       (path, transl_apply obj_init oexprs)
-   | Tclass_let (rec_flag, defs, vals, cl) ->
--      let path, obj_init = transl_class_rebind obj_init cl in
-+      let path, obj_init = transl_class_rebind obj_init cl vf in
-       (path, Translcore.transl_let rec_flag defs obj_init)
-   | Tclass_structure _ -> raise Exit
-   | Tclass_constraint (cl', _, _, _) ->
--      let path, obj_init = transl_class_rebind obj_init cl' in
-+      let path, obj_init = transl_class_rebind obj_init cl' vf in
-       let rec check_constraint = function
-           Tcty_constr(path', _, _) when Path.same path path' -> ()
-         | Tcty_fun (_, _, cty) -> check_constraint cty
-@@ -430,21 +422,21 @@
-       check_constraint cl.cl_type;
-       (path, obj_init)
- 
--let rec transl_class_rebind_0 self obj_init cl =
-+let rec transl_class_rebind_0 self obj_init cl vf =
-   match cl.cl_desc with
-     Tclass_let (rec_flag, defs, vals, cl) ->
--      let path, obj_init = transl_class_rebind_0 self obj_init cl in
-+      let path, obj_init = transl_class_rebind_0 self obj_init cl vf in
-       (path, Translcore.transl_let rec_flag defs obj_init)
-   | _ ->
--      let path, obj_init = transl_class_rebind obj_init cl in
-+      let path, obj_init = transl_class_rebind obj_init cl vf in
-       (path, lfunction [self] obj_init)
- 
--let transl_class_rebind ids cl =
-+let transl_class_rebind ids cl vf =
-   try
-     let obj_init = Ident.create "obj_init"
-     and self = Ident.create "self" in
-     let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
--    let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in
-+    let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
-     if not (Translcore.check_recursive_lambda ids obj_init') then
-       raise(Error(cl.cl_loc, Illegal_class_expr));
-     let id = (obj_init' = lfunction [self] obj_init0) in
-@@ -592,9 +584,9 @@
- *)
- 
- 
--let transl_class ids cl_id arity pub_meths cl =
-+let transl_class ids cl_id arity pub_meths cl vflag =
-   (* First check if it is not only a rebind *)
--  let rebind = transl_class_rebind ids cl in
-+  let rebind = transl_class_rebind ids cl vflag in
-   if rebind <> lambda_unit then rebind else
- 
-   (* Prepare for heavy environment handling *)
-@@ -696,9 +688,7 @@
-   (* Simplest case: an object defined at toplevel (ids=[]) *)
-   if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
- 
--  let concrete =
--    ids = [] ||
--    Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
-+  let concrete = (vflag = Concrete)
-   and lclass lam =
-     let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
-     Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
-@@ -800,11 +790,11 @@
- 
- (* Wrapper for class compilation *)
- 
--let transl_class ids cl_id arity pub_meths cl =
--  oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl
-+let transl_class ids cl_id arity pub_meths cl vf =
-+  oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf
- 
- let () =
--  transl_object := (fun id meths cl -> transl_class [] id 0 meths cl)
-+  transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete)
- 
- (* Error report *)
- 
-Index: bytecomp/translclass.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.mli,v
-retrieving revision 1.11
-diff -u -r1.11 translclass.mli
---- bytecomp/translclass.mli   12 Aug 2004 12:55:11 -0000      1.11
-+++ bytecomp/translclass.mli   5 Apr 2006 02:26:00 -0000
-@@ -16,7 +16,8 @@
- open Lambda
- 
- val transl_class :
--  Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;;
-+  Ident.t list -> Ident.t ->
-+  int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;;
- 
- type error = Illegal_class_expr | Tags of string * string
- 
-Index: bytecomp/translmod.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translmod.ml,v
-retrieving revision 1.51
-diff -u -r1.51 translmod.ml
---- bytecomp/translmod.ml      12 Aug 2004 12:55:11 -0000      1.51
-+++ bytecomp/translmod.ml      5 Apr 2006 02:26:00 -0000
-@@ -317,10 +317,10 @@
-   | Tstr_open path :: rem ->
-       transl_structure fields cc rootpath rem
-   | Tstr_class cl_list :: rem ->
--      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
-       Lletrec(List.map
--                (fun (id, arity, meths, cl) ->
--                  (id, transl_class ids id arity meths cl))
-+                (fun (id, arity, meths, cl, vf) ->
-+                  (id, transl_class ids id arity meths cl vf))
-                 cl_list,
-               transl_structure (List.rev ids @ fields) cc rootpath rem)
-   | Tstr_cltype cl_list :: rem ->
-@@ -414,11 +414,11 @@
-   | Tstr_open path :: rem ->
-       transl_store subst rem
-   | Tstr_class cl_list :: rem ->
--      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
-       let lam =
-         Lletrec(List.map
--                  (fun (id, arity, meths, cl) ->
--                     (id, transl_class ids id arity meths cl))
-+                  (fun (id, arity, meths, cl, vf) ->
-+                     (id, transl_class ids id arity meths cl vf))
-                   cl_list,
-                 store_idents ids) in
-       Lsequence(subst_lambda subst lam,
-@@ -485,7 +485,7 @@
-   | Tstr_modtype(id, decl) :: rem -> defined_idents rem
-   | Tstr_open path :: rem -> defined_idents rem
-   | Tstr_class cl_list :: rem ->
--      List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem
-+      List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
-   | Tstr_cltype cl_list :: rem -> defined_idents rem
-   | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
- 
-@@ -603,14 +603,14 @@
-   | Tstr_class cl_list ->
-       (* we need to use unique names for the classes because there might
-          be a value named identically *)
--      let ids = List.map (fun (i, _, _, _) -> i) cl_list in
-+      let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
-       List.iter set_toplevel_unique_name ids;
-       Lletrec(List.map
--                (fun (id, arity, meths, cl) ->
--                   (id, transl_class ids id arity meths cl))
-+                (fun (id, arity, meths, cl, vf) ->
-+                   (id, transl_class ids id arity meths cl vf))
-                 cl_list,
-               make_sequence
--                (fun (id, _, _, _) -> toploop_setvalue_id id)
-+                (fun (id, _, _, _, _) -> toploop_setvalue_id id)
-                 cl_list)
-   | Tstr_cltype cl_list ->
-       lambda_unit
-Index: driver/main_args.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/driver/main_args.ml,v
-retrieving revision 1.48
-diff -u -r1.48 main_args.ml
---- driver/main_args.ml        4 Jan 2006 16:55:49 -0000       1.48
-+++ driver/main_args.ml        5 Apr 2006 02:26:00 -0000
-@@ -136,11 +136,11 @@
-       \032    E/e enable/disable fragile match\n\
-       \032    F/f enable/disable partially applied function\n\
-       \032    L/l enable/disable labels omitted in application\n\
--      \032    M/m enable/disable overridden method\n\
-+      \032    M/m enable/disable overridden methods\n\
-       \032    P/p enable/disable partial match\n\
-       \032    S/s enable/disable non-unit statement\n\
-       \032    U/u enable/disable unused match case\n\
--      \032    V/v enable/disable hidden instance variable\n\
-+      \032    V/v enable/disable overridden instance variables\n\
-       \032    Y/y enable/disable suspicious unused variables\n\
-       \032    Z/z enable/disable all other unused variables\n\
-       \032    X/x enable/disable all other warnings\n\
-Index: driver/optmain.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/driver/optmain.ml,v
-retrieving revision 1.87
-diff -u -r1.87 optmain.ml
---- driver/optmain.ml  4 Jan 2006 16:55:49 -0000       1.87
-+++ driver/optmain.ml  5 Apr 2006 02:26:00 -0000
-@@ -173,7 +173,7 @@
-          \032    P/p enable/disable partial match\n\
-          \032    S/s enable/disable non-unit statement\n\
-          \032    U/u enable/disable unused match case\n\
--         \032    V/v enable/disable hidden instance variables\n\
-+         \032    V/v enable/disable overridden instance variables\n\
-          \032    Y/y enable/disable suspicious unused variables\n\
-          \032    Z/z enable/disable all other unused variables\n\
-          \032    X/x enable/disable all other warnings\n\
-Index: stdlib/camlinternalOO.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
-retrieving revision 1.14
-diff -u -r1.14 camlinternalOO.ml
---- stdlib/camlinternalOO.ml   25 Oct 2005 18:34:07 -0000      1.14
-+++ stdlib/camlinternalOO.ml   5 Apr 2006 02:26:00 -0000
-@@ -206,7 +206,11 @@
-      (table.methods_by_name, table.methods_by_label, table.hidden_meths,
-       table.vars, virt_meth_labs, vars)
-      :: table.previous_states;
--  table.vars <- Vars.empty;
-+  table.vars <-
-+    Vars.fold
-+      (fun lab info tvars ->
-+        if List.mem lab vars then Vars.add lab info tvars else tvars)
-+      table.vars Vars.empty;
-   let by_name = ref Meths.empty in
-   let by_label = ref Labs.empty in
-   List.iter2
-@@ -255,9 +259,11 @@
-   index
- 
- let new_variable table name =
--  let index = new_slot table in
--  table.vars <- Vars.add name index table.vars;
--  index
-+  try Vars.find name table.vars
-+  with Not_found ->
-+    let index = new_slot table in
-+    table.vars <- Vars.add name index table.vars;
-+    index
- 
- let to_array arr =
-   if arr = Obj.magic 0 then [||] else arr
-@@ -265,16 +271,17 @@
- let new_methods_variables table meths vals =
-   let meths = to_array meths in
-   let nmeths = Array.length meths and nvals = Array.length vals in
--  let index = new_variable table vals.(0) in
--  let res = Array.create (nmeths + 1) index in
--  for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done;
-+  let res = Array.create (nmeths + nvals) 0 in
-   for i = 0 to nmeths - 1 do
--    res.(i+1) <- get_method_label table meths.(i)
-+    res.(i) <- get_method_label table meths.(i)
-+  done;
-+  for i = 0 to nvals - 1 do
-+    res.(i+nmeths) <- new_variable table vals.(i)
-   done;
-   res
- 
- let get_variable table name =
--  Vars.find name table.vars
-+  try Vars.find name table.vars with Not_found -> assert false
- 
- let get_variables table names =
-   Array.map (get_variable table) names
-@@ -315,9 +322,12 @@
-   let init =
-     if top then super cla env else Obj.repr (super cla) in
-   widen cla;
--  (init, Array.map (get_variable cla) (to_array vals),
--   Array.map (fun nm -> get_method cla (get_method_label cla nm))
--     (to_array concr_meths))
-+  Array.concat
-+    [[| repr init |];
-+     magic (Array.map (get_variable cla) (to_array vals) : int array);
-+     Array.map
-+       (fun nm -> repr (get_method cla (get_method_label cla nm) : closure))
-+       (to_array concr_meths) ]
- 
- let make_class pub_meths class_init =
-   let table = create_table pub_meths in
-Index: stdlib/camlinternalOO.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
-retrieving revision 1.9
-diff -u -r1.9 camlinternalOO.mli
---- stdlib/camlinternalOO.mli  25 Oct 2005 18:34:07 -0000      1.9
-+++ stdlib/camlinternalOO.mli  5 Apr 2006 02:26:00 -0000
-@@ -46,8 +46,7 @@
- val init_class : table -> unit
- val inherits :
-     table -> string array -> string array -> string array ->
--    (t * (table -> obj -> Obj.t) * t * obj) -> bool ->
--    (Obj.t * int array * closure array)
-+    (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array
- val make_class :
-     string array -> (table -> Obj.t -> t) ->
-     (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
-@@ -79,6 +78,7 @@
- 
- (** {6 Builtins to reduce code size} *)
- 
-+(*
- val get_const : t -> closure
- val get_var : int -> closure
- val get_env : int -> int -> closure
-@@ -103,6 +103,7 @@
- val send_var : tag -> int -> int -> closure
- val send_env : tag -> int -> int -> int -> closure
- val send_meth : tag -> label -> int -> closure
-+*)
- 
- type impl =
-     GetConst
-Index: stdlib/sys.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/stdlib/sys.ml,v
-retrieving revision 1.142
-diff -u -r1.142 sys.ml
---- stdlib/sys.ml      22 Mar 2006 12:39:39 -0000      1.142
-+++ stdlib/sys.ml      5 Apr 2006 02:26:00 -0000
-@@ -78,4 +78,4 @@
- 
- (* OCaml version string, must be in the format described in sys.mli. *)
- 
--let ocaml_version = "3.10+dev4 (2006-03-22)";;
-+let ocaml_version = "3.10+dev5 (2006-04-05)";;
-Index: tools/depend.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/tools/depend.ml,v
-retrieving revision 1.9
-diff -u -r1.9 depend.ml
---- tools/depend.ml    23 Mar 2005 03:08:37 -0000      1.9
-+++ tools/depend.ml    5 Apr 2006 02:26:00 -0000
-@@ -87,7 +87,7 @@
- 
- and add_class_type_field bv = function
-     Pctf_inher cty -> add_class_type bv cty
--  | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty
-+  | Pctf_val(_, _, _, ty, _) -> add_type bv ty
-   | Pctf_virt(_, _, ty, _) -> add_type bv ty
-   | Pctf_meth(_, _, ty, _) -> add_type bv ty
-   | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-@@ -280,6 +280,7 @@
- and add_class_field bv = function
-     Pcf_inher(ce, _) -> add_class_expr bv ce
-   | Pcf_val(_, _, e, _) -> add_expr bv e
-+  | Pcf_valvirt(_, _, ty, _)
-   | Pcf_virt(_, _, ty, _) -> add_type bv ty
-   | Pcf_meth(_, _, e, _) -> add_expr bv e
-   | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-Index: tools/ocamlprof.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/tools/ocamlprof.ml,v
-retrieving revision 1.38
-diff -u -r1.38 ocamlprof.ml
---- tools/ocamlprof.ml 24 Mar 2005 17:20:54 -0000      1.38
-+++ tools/ocamlprof.ml 5 Apr 2006 02:26:00 -0000
-@@ -328,7 +328,7 @@
-       rewrite_patexp_list iflag spat_sexp_list
-   | Pcf_init sexp ->
-       rewrite_exp iflag sexp
--  | Pcf_virt _ | Pcf_cstr _  -> ()
-+  | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _  -> ()
- 
- and rewrite_class_expr iflag cexpr =
-   match cexpr.pcl_desc with
-Index: otherlibs/labltk/browser/searchpos.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/otherlibs/labltk/browser/searchpos.ml,v
-retrieving revision 1.48
-diff -u -r1.48 searchpos.ml
---- otherlibs/labltk/browser/searchpos.ml      23 Mar 2005 03:08:37 -0000      1.48
-+++ otherlibs/labltk/browser/searchpos.ml      5 Apr 2006 02:26:01 -0000
-@@ -141,9 +141,8 @@
-         List.iter cfl ~f:
-           begin function
-               Pctf_inher cty -> search_pos_class_type cty ~pos ~env
--            | Pctf_val (_, _, Some ty, loc) ->
-+            | Pctf_val (_, _, _, ty, loc) ->
-                 if in_loc loc ~pos then search_pos_type ty ~pos ~env
--            | Pctf_val _ -> ()
-             | Pctf_virt (_, _, ty, loc) ->
-                 if in_loc loc ~pos then search_pos_type ty ~pos ~env
-             | Pctf_meth (_, _, ty, loc) ->
-@@ -675,7 +674,7 @@
-   | Tstr_modtype _ -> ()
-   | Tstr_open _ -> ()
-   | Tstr_class l ->
--      List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos)
-+      List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos)
-   | Tstr_cltype _ -> ()
-   | Tstr_include (m, _) -> search_pos_module_expr m ~pos
-   end
-@@ -685,7 +684,8 @@
-     begin function
-         Cf_inher (cl, _, _) ->
-           search_pos_class_expr cl ~pos
--      | Cf_val (_, _, exp) -> search_pos_expr exp ~pos
-+      | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
-+      | Cf_val _ -> ()
-       | Cf_meth (_, exp) -> search_pos_expr exp ~pos
-       | Cf_let (_, pel, iel) ->
-           List.iter pel ~f:
-Index: ocamldoc/Makefile
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/Makefile,v
-retrieving revision 1.61
-diff -u -r1.61 Makefile
---- ocamldoc/Makefile  4 Jan 2006 16:55:49 -0000       1.61
-+++ ocamldoc/Makefile  5 Apr 2006 02:26:01 -0000
-@@ -31,7 +31,7 @@
- MKDIR=mkdir -p
- CP=cp -f
- OCAMLDOC=ocamldoc
--OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
-+OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
- OCAMLDOC_OPT=$(OCAMLDOC).opt
- OCAMLDOC_LIBCMA=odoc_info.cma
- OCAMLDOC_LIBCMI=odoc_info.cmi
-@@ -188,12 +188,12 @@
-       ../otherlibs/num/num.mli
- 
- all: exe lib
--      $(MAKE) manpages
- 
- exe: $(OCAMLDOC)
- lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
- 
- opt.opt: exeopt libopt
-+      $(MAKE) manpages
- exeopt: $(OCAMLDOC_OPT)
- libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
- debug:
-Index: ocamldoc/odoc_ast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_ast.ml,v
-retrieving revision 1.27
-diff -u -r1.27 odoc_ast.ml
---- ocamldoc/odoc_ast.ml       4 Jan 2006 16:55:49 -0000       1.27
-+++ ocamldoc/odoc_ast.ml       5 Apr 2006 02:26:01 -0000
-@@ -88,7 +88,7 @@
-             ident_type_decl_list
-       | Typedtree.Tstr_class info_list ->
-           List.iter
--            (fun ((id,_,_,_) as ci) ->
-+            (fun ((id,_,_,_,_) as ci) ->
-               Hashtbl.add table (C (Name.from_ident id))
-                 (Typedtree.Tstr_class [ci]))
-             info_list
-@@ -146,7 +146,7 @@
- 
-     let search_class_exp table name =
-       match Hashtbl.find table (C name) with
--      | (Typedtree.Tstr_class [(_,_,_,ce)]) ->
-+      | (Typedtree.Tstr_class [(_,_,_,ce,_)]) ->
-           (
-            try
-              let type_decl = search_type_declaration table name in
-@@ -184,7 +184,7 @@
-       let rec iter = function
-         | [] ->
-             raise Not_found
--        | Typedtree.Cf_val (_, ident, exp) :: q
-+        | Typedtree.Cf_val (_, ident, Some exp, _) :: q
-           when Name.from_ident ident = name ->
-             exp.Typedtree.exp_type
-         | _ :: q ->
-@@ -523,7 +523,8 @@
-               p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum
-               q
- 
--        | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q ->
-+        | (Parsetree.Pcf_val (label, mutable_flag, _, loc) |
-+           Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q ->
-             let complete_name = Name.concat current_class_name label in
-             let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-             let type_exp =
-Index: ocamldoc/odoc_sig.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/ocamldoc/odoc_sig.ml,v
-retrieving revision 1.37
-diff -u -r1.37 odoc_sig.ml
---- ocamldoc/odoc_sig.ml       4 Jan 2006 16:55:50 -0000       1.37
-+++ ocamldoc/odoc_sig.ml       5 Apr 2006 02:26:01 -0000
-@@ -107,7 +107,7 @@
-       | _ -> assert false
- 
-     let search_attribute_type name class_sig =
--      let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
-+      let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in
-       type_expr
- 
-     let search_method_type name class_sig =
-@@ -269,7 +269,7 @@
-           [] -> pos_limit
-         | ele2 :: _ ->
-             match ele2 with
--              Parsetree.Pctf_val (_, _, _, loc)
-+              Parsetree.Pctf_val (_, _, _, _, loc)
-             | Parsetree.Pctf_virt (_, _, _, loc)
-             | Parsetree.Pctf_meth (_, _, _, loc)
-             | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum
-@@ -330,7 +330,7 @@
-             in
-             ([], ele_comments)
- 
--        | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q ->
-+        | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q ->
-             (* of (string * mutable_flag * core_type option * Location.t)*)
-             let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in
-             let complete_name = Name.concat current_class_name name in
-Index: camlp4/camlp4/ast2pt.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/ast2pt.ml,v
-retrieving revision 1.36
-diff -u -r1.36 ast2pt.ml
---- camlp4/camlp4/ast2pt.ml    29 Jun 2005 04:11:26 -0000      1.36
-+++ camlp4/camlp4/ast2pt.ml    5 Apr 2006 02:26:01 -0000
-@@ -244,6 +244,7 @@
- ;
- value mkmutable m = if m then Mutable else Immutable;
- value mkprivate m = if m then Private else Public;
-+value mkvirtual m = if m then Virtual else Concrete;
- value mktrecord (loc, n, m, t) =
-   (n, mkmutable m, ctyp (mkpolytype t), mkloc loc);
- value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc);
-@@ -862,8 +863,8 @@
-   | CgInh loc ct -> [Pctf_inher (class_type ct) :: l]
-   | CgMth loc s pf t ->
-       [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l]
--  | CgVal loc s b t ->
--      [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l]
-+  | CgVal loc s b v t ->
-+      [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l]
-   | CgVir loc s b t ->
-       [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
- and class_expr =
-@@ -907,7 +908,9 @@
-       [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l]
-   | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l]
-   | CrVir loc s b t ->
--      [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ]
-+      [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l]
-+  | CrVvr loc s b t ->
-+      [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] ]
- ;
- 
- value interf ast = List.fold_right sig_item ast [];
-Index: camlp4/camlp4/mLast.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/mLast.mli,v
-retrieving revision 1.18
-diff -u -r1.18 mLast.mli
---- camlp4/camlp4/mLast.mli    29 Jun 2005 04:11:26 -0000      1.18
-+++ camlp4/camlp4/mLast.mli    5 Apr 2006 02:26:01 -0000
-@@ -180,7 +180,7 @@
-   | CgDcl of loc and list class_sig_item
-   | CgInh of loc and class_type
-   | CgMth of loc and string and bool and ctyp
--  | CgVal of loc and string and bool and ctyp
-+  | CgVal of loc and string and bool and bool and ctyp
-   | CgVir of loc and string and bool and ctyp ]
- and class_expr =
-   [ CeApp of loc and class_expr and expr
-@@ -196,7 +196,8 @@
-   | CrIni of loc and expr
-   | CrMth of loc and string and bool and expr and option ctyp
-   | CrVal of loc and string and bool and expr
--  | CrVir of loc and string and bool and ctyp ]
-+  | CrVir of loc and string and bool and ctyp
-+  | CrVvr of loc and string and bool and ctyp ]
- ;
- 
- external loc_of_ctyp : ctyp -> loc = "%field0";
-Index: camlp4/camlp4/reloc.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/camlp4/reloc.ml,v
-retrieving revision 1.18
-diff -u -r1.18 reloc.ml
---- camlp4/camlp4/reloc.ml     29 Jun 2005 04:11:26 -0000      1.18
-+++ camlp4/camlp4/reloc.ml     5 Apr 2006 02:26:01 -0000
-@@ -350,7 +350,7 @@
-     | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1)
-     | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1)
-     | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3)
--    | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3)
-+    | CgVal loc x1 x2 x3 x4 -> let nloc = floc loc in CgVal nloc x1 x2 x3 (ctyp floc sh x4)
-     | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ]
- and class_expr floc sh =
-   self where rec self =
-@@ -377,5 +377,6 @@
-     | CrMth loc x1 x2 x3 x4 ->
-         let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4)
-     | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3)
--    | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ]
-+    | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3)
-+    | CrVvr loc x1 x2 x3 -> let nloc = floc loc in CrVvr nloc x1 x2 (ctyp floc sh x3) ]
- ;
-Index: camlp4/etc/pa_o.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pa_o.ml,v
-retrieving revision 1.66
-diff -u -r1.66 pa_o.ml
---- camlp4/etc/pa_o.ml 29 Jun 2005 04:11:26 -0000      1.66
-+++ camlp4/etc/pa_o.ml 5 Apr 2006 02:26:01 -0000
-@@ -1037,8 +1037,14 @@
-   class_str_item:
-     [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] ->
-           <:class_str_item< inherit $ce$ $opt:pb$ >>
--      | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
--          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
-+      | "val"; "mutable"; lab = label; e = cvalue_binding ->
-+          <:class_str_item< value mutable $lab$ = $e$ >>
-+      | "val"; lab = label; e = cvalue_binding ->
-+          <:class_str_item< value $lab$ = $e$ >>
-+      | "val"; "mutable"; "virtual"; lab = label; ":"; t = ctyp ->
-+          <:class_str_item< value virtual mutable $lab$ : $t$ >>
-+      | "val"; "virtual"; mf = OPT "mutable"; lab = label; ":"; t = ctyp ->
-+          <:class_str_item< value virtual $opt:o2b mf$ $lab$ : $t$ >>
-       | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
-           <:class_str_item< method virtual private $l$ : $t$ >>
-       | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
-@@ -1087,8 +1093,9 @@
-   ;
-   class_sig_item:
-     [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >>
--      | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
--          <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
-+      | "val"; mf = OPT "mutable"; vf = OPT "virtual";
-+        l = label; ":"; t = ctyp ->
-+          <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
-       | "method"; "private"; "virtual"; l = label; ":"; t = poly_type ->
-           <:class_sig_item< method virtual private $l$ : $t$ >>
-       | "method"; "virtual"; "private"; l = label; ":"; t = poly_type ->
-Index: camlp4/etc/pr_o.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/etc/pr_o.ml,v
-retrieving revision 1.51
-diff -u -r1.51 pr_o.ml
---- camlp4/etc/pr_o.ml 5 Jan 2006 10:44:29 -0000       1.51
-+++ camlp4/etc/pr_o.ml 5 Apr 2006 02:26:01 -0000
-@@ -1768,10 +1768,11 @@
-                   [: `S LR "method"; private_flag pf; `label lab;
-                      `S LR ":" :];
-                `ctyp t "" k :]
--      | MLast.CgVal _ lab mf t ->
-+      | MLast.CgVal _ lab mf vf t ->
-           fun curr next dg k ->
-             [: `HVbox
--                  [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :];
-+                  [: `S LR "val"; mutable_flag mf; virtual_flag vf;
-+                     `label lab; `S LR ":" :];
-                `ctyp t "" k :]
-       | MLast.CgVir _ lab pf t ->
-           fun curr next dg k ->
-Index: camlp4/meta/pa_r.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/pa_r.ml,v
-retrieving revision 1.64
-diff -u -r1.64 pa_r.ml
---- camlp4/meta/pa_r.ml        29 Jun 2005 04:11:26 -0000      1.64
-+++ camlp4/meta/pa_r.ml        5 Apr 2006 02:26:01 -0000
-@@ -658,7 +658,9 @@
-       | "inherit"; ce = class_expr; pb = OPT as_lident ->
-           <:class_str_item< inherit $ce$ $opt:pb$ >>
-       | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding ->
--          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >>
-+          <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> 
-+      | "value"; "virtual"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
-+          <:class_str_item< value virtual $opt:o2b mf$ $l$ : $t$ >>
-       | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
-           <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
-       | "method"; pf = OPT "private"; l = label; topt = OPT polyt;
-@@ -701,8 +703,9 @@
-     [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
-           <:class_sig_item< declare $list:st$ end >>
-       | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >>
--      | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp ->
--          <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >>
-+      | "value"; mf = OPT "mutable"; vf = OPT "virtual";
-+        l = label; ":"; t = ctyp ->
-+          <:class_sig_item< value $opt:o2b mf$ $opt:o2b vf$ $l$ : $t$ >>
-       | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp ->
-           <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >>
-       | "method"; pf = OPT "private"; l = label; ":"; t = ctyp ->
-Index: camlp4/meta/q_MLast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/meta/q_MLast.ml,v
-retrieving revision 1.60
-diff -u -r1.60 q_MLast.ml
---- camlp4/meta/q_MLast.ml     29 Jun 2005 04:11:26 -0000      1.60
-+++ camlp4/meta/q_MLast.ml     5 Apr 2006 02:26:01 -0000
-@@ -947,6 +947,8 @@
-           Qast.Node "CrDcl" [Qast.Loc; st]
-       | "inherit"; ce = class_expr; pb = SOPT as_lident ->
-           Qast.Node "CrInh" [Qast.Loc; ce; pb]
-+      | "value"; "virtual"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
-+          Qast.Node "CrVvr" [Qast.Loc; l; o2b mf; t]
-       | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding ->
-           Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e]
-       | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
-@@ -992,8 +994,9 @@
-     [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" ->
-           Qast.Node "CgDcl" [Qast.Loc; st]
-       | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs]
--      | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp ->
--          Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t]
-+      | "value"; mf = SOPT "mutable"; vf = SOPT "virtual";
-+        l = label; ":"; t = ctyp ->
-+          Qast.Node "CgVal" [Qast.Loc; l; o2b mf; o2b vf; t]
-       | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
-           Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t]
-       | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp ->
-Index: camlp4/ocaml_src/camlp4/ast2pt.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/ast2pt.ml,v
-retrieving revision 1.36
-diff -u -r1.36 ast2pt.ml
---- camlp4/ocaml_src/camlp4/ast2pt.ml  29 Jun 2005 04:11:26 -0000      1.36
-+++ camlp4/ocaml_src/camlp4/ast2pt.ml  5 Apr 2006 02:26:01 -0000
-@@ -227,6 +227,7 @@
- ;;
- let mkmutable m = if m then Mutable else Immutable;;
- let mkprivate m = if m then Private else Public;;
-+let mkvirtual m = if m then Virtual else Concrete;;
- let mktrecord (loc, n, m, t) =
-   n, mkmutable m, ctyp (mkpolytype t), mkloc loc
- ;;
-@@ -878,8 +879,8 @@
-   | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l
-   | CgMth (loc, s, pf, t) ->
-       Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l
--  | CgVal (loc, s, b, t) ->
--      Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l
-+  | CgVal (loc, s, b, v, t) ->
-+      Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l
-   | CgVir (loc, s, b, t) ->
-       Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
- and class_expr =
-@@ -923,6 +924,8 @@
-   | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l
-   | CrVir (loc, s, b, t) ->
-       Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l
-+  | CrVvr (loc, s, b, t) ->
-+      Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l
- ;;
- 
- let interf ast = List.fold_right sig_item ast [];;
-Index: camlp4/ocaml_src/camlp4/mLast.mli
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/mLast.mli,v
-retrieving revision 1.20
-diff -u -r1.20 mLast.mli
---- camlp4/ocaml_src/camlp4/mLast.mli  29 Jun 2005 04:11:26 -0000      1.20
-+++ camlp4/ocaml_src/camlp4/mLast.mli  5 Apr 2006 02:26:01 -0000
-@@ -180,7 +180,7 @@
-   | CgDcl of loc * class_sig_item list
-   | CgInh of loc * class_type
-   | CgMth of loc * string * bool * ctyp
--  | CgVal of loc * string * bool * ctyp
-+  | CgVal of loc * string * bool * bool * ctyp
-   | CgVir of loc * string * bool * ctyp
- and class_expr =
-     CeApp of loc * class_expr * expr
-@@ -197,6 +197,7 @@
-   | CrMth of loc * string * bool * expr * ctyp option
-   | CrVal of loc * string * bool * expr
-   | CrVir of loc * string * bool * ctyp
-+  | CrVvr of loc * string * bool * ctyp
- ;;
- 
- external loc_of_ctyp : ctyp -> loc = "%field0";;
-Index: camlp4/ocaml_src/camlp4/reloc.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/camlp4/reloc.ml,v
-retrieving revision 1.20
-diff -u -r1.20 reloc.ml
---- camlp4/ocaml_src/camlp4/reloc.ml   29 Jun 2005 04:11:26 -0000      1.20
-+++ camlp4/ocaml_src/camlp4/reloc.ml   5 Apr 2006 02:26:01 -0000
-@@ -430,8 +430,8 @@
-         let nloc = floc loc in CgInh (nloc, class_type floc sh x1)
-     | CgMth (loc, x1, x2, x3) ->
-         let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3)
--    | CgVal (loc, x1, x2, x3) ->
--        let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3)
-+    | CgVal (loc, x1, x2, x3, x4) ->
-+        let nloc = floc loc in CgVal (nloc, x1, x2, x3, ctyp floc sh x4)
-     | CgVir (loc, x1, x2, x3) ->
-         let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3)
-   in
-@@ -478,6 +478,8 @@
-         let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3)
-     | CrVir (loc, x1, x2, x3) ->
-         let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3)
-+    | CrVvr (loc, x1, x2, x3) ->
-+        let nloc = floc loc in CrVvr (nloc, x1, x2, ctyp floc sh x3)
-   in
-   self
- ;;
-Index: camlp4/ocaml_src/meta/pa_r.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/pa_r.ml,v
-retrieving revision 1.59
-diff -u -r1.59 pa_r.ml
---- camlp4/ocaml_src/meta/pa_r.ml      29 Jun 2005 04:11:26 -0000      1.59
-+++ camlp4/ocaml_src/meta/pa_r.ml      5 Apr 2006 02:26:01 -0000
-@@ -2161,6 +2161,15 @@
-         (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _
-            (_loc : Lexing.position * Lexing.position) ->
-            (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item));
-+      [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
-+       Gramext.Sopt (Gramext.Stoken ("", "mutable"));
-+       Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-+       Gramext.Stoken ("", ":");
-+       Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-+      Gramext.action
-+        (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ _
-+           (_loc : Lexing.position * Lexing.position) ->
-+           (MLast.CrVvr (_loc, l, o2b mf, t) : 'class_str_item));
-       [Gramext.Stoken ("", "value");
-        Gramext.Sopt (Gramext.Stoken ("", "mutable"));
-        Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-@@ -2338,13 +2347,15 @@
-            (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item));
-       [Gramext.Stoken ("", "value");
-        Gramext.Sopt (Gramext.Stoken ("", "mutable"));
-+       Gramext.Sopt (Gramext.Stoken ("", "virtual"));
-        Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-        Gramext.Stoken ("", ":");
-        Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-       Gramext.action
--        (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _
-+        (fun (t : 'ctyp) _ (l : 'label) (vf : string option)
-+           (mf : string option) _
-            (_loc : Lexing.position * Lexing.position) ->
--           (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item));
-+           (MLast.CgVal (_loc, l, o2b mf, o2b vf, t) : 'class_sig_item));
-       [Gramext.Stoken ("", "inherit");
-        Gramext.Snterm
-          (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
-Index: camlp4/ocaml_src/meta/q_MLast.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/ocaml_src/meta/q_MLast.ml,v
-retrieving revision 1.65
-diff -u -r1.65 q_MLast.ml
---- camlp4/ocaml_src/meta/q_MLast.ml   12 Jan 2006 08:54:21 -0000      1.65
-+++ camlp4/ocaml_src/meta/q_MLast.ml   5 Apr 2006 02:26:01 -0000
-@@ -3152,9 +3152,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__17))])],
-+                      (Qast.Str x : 'e__18))])],
-           Gramext.action
--            (fun (a : 'e__17 option)
-+            (fun (a : 'e__18 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3191,9 +3191,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__16))])],
-+                      (Qast.Str x : 'e__17))])],
-           Gramext.action
--            (fun (a : 'e__16 option)
-+            (fun (a : 'e__17 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3216,9 +3216,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__15))])],
-+                      (Qast.Str x : 'e__16))])],
-           Gramext.action
--            (fun (a : 'e__15 option)
-+            (fun (a : 'e__16 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3235,6 +3235,31 @@
-            (_loc : Lexing.position * Lexing.position) ->
-            (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) :
-             'class_str_item));
-+      [Gramext.Stoken ("", "value"); Gramext.Stoken ("", "virtual");
-+       Gramext.srules
-+         [[Gramext.Sopt
-+             (Gramext.srules
-+                [[Gramext.Stoken ("", "mutable")],
-+                 Gramext.action
-+                   (fun (x : string)
-+                      (_loc : Lexing.position * Lexing.position) ->
-+                      (Qast.Str x : 'e__15))])],
-+          Gramext.action
-+            (fun (a : 'e__15 option)
-+               (_loc : Lexing.position * Lexing.position) ->
-+               (Qast.Option a : 'a_opt));
-+          [Gramext.Snterm
-+             (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
-+          Gramext.action
-+            (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
-+               (a : 'a_opt))];
-+       Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e));
-+       Gramext.Stoken ("", ":");
-+       Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-+      Gramext.action
-+        (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ _
-+           (_loc : Lexing.position * Lexing.position) ->
-+           (Qast.Node ("CrVvr", [Qast.Loc; l; o2b mf; t]) : 'class_str_item));
-       [Gramext.Stoken ("", "inherit");
-        Gramext.Snterm
-          (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e));
-@@ -3366,9 +3391,9 @@
-                  Gramext.action
-                    (fun _ (csf : 'class_sig_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (csf : 'e__18))])],
-+                      (csf : 'e__19))])],
-           Gramext.action
--            (fun (a : 'e__18 list)
-+            (fun (a : 'e__19 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -3446,9 +3471,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__22))])],
-+                      (Qast.Str x : 'e__24))])],
-           Gramext.action
--            (fun (a : 'e__22 option)
-+            (fun (a : 'e__24 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3471,9 +3496,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__21))])],
-+                      (Qast.Str x : 'e__23))])],
-           Gramext.action
--            (fun (a : 'e__21 option)
-+            (fun (a : 'e__23 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3496,9 +3521,26 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__20))])],
-+                      (Qast.Str x : 'e__21))])],
-           Gramext.action
--            (fun (a : 'e__20 option)
-+            (fun (a : 'e__21 option)
-+               (_loc : Lexing.position * Lexing.position) ->
-+               (Qast.Option a : 'a_opt));
-+          [Gramext.Snterm
-+             (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))],
-+          Gramext.action
-+            (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) ->
-+               (a : 'a_opt))];
-+       Gramext.srules
-+         [[Gramext.Sopt
-+             (Gramext.srules
-+                [[Gramext.Stoken ("", "virtual")],
-+                 Gramext.action
-+                   (fun (x : string)
-+                      (_loc : Lexing.position * Lexing.position) ->
-+                      (Qast.Str x : 'e__22))])],
-+          Gramext.action
-+            (fun (a : 'e__22 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3510,9 +3552,10 @@
-        Gramext.Stoken ("", ":");
-        Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))],
-       Gramext.action
--        (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _
-+        (fun (t : 'ctyp) _ (l : 'label) (vf : 'a_opt) (mf : 'a_opt) _
-            (_loc : Lexing.position * Lexing.position) ->
--           (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item));
-+           (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; o2b vf; t]) :
-+            'class_sig_item));
-       [Gramext.Stoken ("", "inherit");
-        Gramext.Snterm
-          (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))],
-@@ -3531,9 +3574,9 @@
-                  Gramext.action
-                    (fun _ (s : 'class_sig_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (s : 'e__19))])],
-+                      (s : 'e__20))])],
-           Gramext.action
--            (fun (a : 'e__19 list)
-+            (fun (a : 'e__20 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -3556,9 +3599,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__23))])],
-+                      (Qast.Str x : 'e__25))])],
-           Gramext.action
--            (fun (a : 'e__23 option)
-+            (fun (a : 'e__25 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3593,9 +3636,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__24))])],
-+                      (Qast.Str x : 'e__26))])],
-           Gramext.action
--            (fun (a : 'e__24 option)
-+            (fun (a : 'e__26 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3713,9 +3756,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__25))])],
-+                      (Qast.Str x : 'e__27))])],
-           Gramext.action
--            (fun (a : 'e__25 option)
-+            (fun (a : 'e__27 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -3922,9 +3965,9 @@
-                  Gramext.action
-                    (fun (x : string)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (Qast.Str x : 'e__26))])],
-+                      (Qast.Str x : 'e__28))])],
-           Gramext.action
--            (fun (a : 'e__26 option)
-+            (fun (a : 'e__28 option)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.Option a : 'a_opt));
-           [Gramext.Snterm
-@@ -4390,9 +4433,9 @@
-                  Gramext.action
-                    (fun _ (e : 'expr)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (e : 'e__29))])],
-+                      (e : 'e__31))])],
-           Gramext.action
--            (fun (a : 'e__29 list)
-+            (fun (a : 'e__31 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4425,9 +4468,9 @@
-                  Gramext.action
-                    (fun _ (e : 'expr)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (e : 'e__28))])],
-+                      (e : 'e__30))])],
-           Gramext.action
--            (fun (a : 'e__28 list)
-+            (fun (a : 'e__30 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4454,9 +4497,9 @@
-                  Gramext.action
-                    (fun _ (e : 'expr)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (e : 'e__27))])],
-+                      (e : 'e__29))])],
-           Gramext.action
--            (fun (a : 'e__27 list)
-+            (fun (a : 'e__29 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4547,9 +4590,9 @@
-                  Gramext.action
-                    (fun _ (cf : 'class_str_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (cf : 'e__30))])],
-+                      (cf : 'e__32))])],
-           Gramext.action
--            (fun (a : 'e__30 list)
-+            (fun (a : 'e__32 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4592,9 +4635,9 @@
-                  Gramext.action
-                    (fun _ (csf : 'class_sig_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (csf : 'e__32))])],
-+                      (csf : 'e__34))])],
-           Gramext.action
--            (fun (a : 'e__32 list)
-+            (fun (a : 'e__34 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-@@ -4623,9 +4666,9 @@
-                  Gramext.action
-                    (fun _ (csf : 'class_sig_item)
-                       (_loc : Lexing.position * Lexing.position) ->
--                      (csf : 'e__31))])],
-+                      (csf : 'e__33))])],
-           Gramext.action
--            (fun (a : 'e__31 list)
-+            (fun (a : 'e__33 list)
-                (_loc : Lexing.position * Lexing.position) ->
-                (Qast.List a : 'a_list));
-           [Gramext.Snterm
-Index: camlp4/top/rprint.ml
-===================================================================
-RCS file: /net/yquem/devel/caml/repository/csl/camlp4/top/rprint.ml,v
-retrieving revision 1.18
-diff -u -r1.18 rprint.ml
---- camlp4/top/rprint.ml       29 Jun 2005 04:11:26 -0000      1.18
-+++ camlp4/top/rprint.ml       5 Apr 2006 02:26:01 -0000
-@@ -288,8 +288,9 @@
-       fprintf ppf "@[<2>method %s%s%s :@ %a;@]"
-         (if priv then "private " else "") (if virt then "virtual " else "")
-         name Toploop.print_out_type.val ty
--  | Ocsg_value name mut ty ->
--      fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "")
-+  | Ocsg_value name mut virt ty ->
-+      fprintf ppf "@[<2>value %s%s%s :@ %a;@]"
-+        (if mut then "mutable " else "") (if virt then "virtual " else "")
-         name Toploop.print_out_type.val ty ]
- ;
- 

diff --git a/testlabl/varunion.ml b/testlabl/varunion.ml
deleted file mode 100644 (file)
index 30a410f..0000000
--- a/testlabl/varunion.ml
+++ /dev/null
@@ -1,435 +0,0 @@
-(* cvs update -r varunion parsing typing bytecomp toplevel *)
-
-type t = private [> ];;
-type u = private [> ] ~ [t];;
-type v = [t | u];;
-let f x = (x : t :> v);;
-
-(* bad *)
-module Mix(X: sig type t = private [> ] end)
-    (Y: sig type t = private [> ] end) =
-  struct type t = [X.t | Y.t] end;;
-
-(* bad *)
-module Mix(X: sig type t = private [> `A of int ] end)
-    (Y: sig type t = private [> `A of bool] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] end;;
-
-(* ok *)
-module Mix(X: sig type t = private [> `A of int ] end)
-    (Y: sig type t = private [> `A of int] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] end;;
-
-(* bad *)
-module Mix(X: sig type t = private [> `A of int ] end)
-    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] end;;
-
-type 'a t = private [> `L of 'a] ~ [`L];;
-
-(* ok *)
-module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
-    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
-  struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
-
-module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
-    (Y: sig type t = private [> `B of bool] ~ [X.t] end) =
-  struct
-    type t = [X.t | Y.t]
-    let which = function #X.t -> `X | #Y.t -> `Y
-  end;;
-
-module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
-    (X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
-    (Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
-  struct
-    type t = [X.t | Y.t]
-    let which = function #X.t -> `X | #Y.t -> `Y
-  end;;
-
-(* ok *)
-module M =
-  Mix(struct type t = [`C of char] end)
-    (struct type t = [`A of int | `C of char] end)
-    (struct type t = [`B of bool | `C of char] end);;
-
-(* bad *)
-module M =
-  Mix(struct type t = [`B of bool] end)
-    (struct type t = [`A of int | `B of bool] end)
-    (struct type t = [`B of bool | `C of char] end);;
-
-(* ok *)
-module M1 = struct type t = [`A of int | `C of char] end
-module M2 = struct type t = [`B of bool | `C of char] end
-module I = struct type t = [`C of char] end
-module M = Mix(I)(M1)(M2) ;;
-
-let c = (`C 'c' : M.t) ;;
-
-module M(X : sig type t = private [> `A] end) = 
-  struct let f (#X.t as x) = x end;;
-
-(* code generation *)
-type t = private [> `A ] ~ [`B];;
-match `B with #t -> 1 | `B -> 2;;
-
-module M : sig type t = private [> `A of int | `B] ~ [`C] end =
-  struct type t = [`A of int | `B | `D of bool] end;;
-let f = function (`C | #M.t) -> 1+1 ;;
-let f = function (`A _ | `B #M.t) -> 1+1 ;;
-
-(* expression *)
-module Mix(X:sig type t = private [> ] val show: t -> string end)
-    (Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) =
-  struct
-    type t = [X.t | Y.t]
-    let show : t -> string = function
-        #X.t as x -> X.show x
-      | #Y.t as y -> Y.show y
-  end;;
-
-module EStr = struct
-  type t = [`Str of string]
-  let show (`Str s) = s
-end
-module EInt = struct
-  type t = [`Int of int]
-  let show (`Int i) = string_of_int i
-end
-module M = Mix(EStr)(EInt);;
-
-module type T = sig type t = private [> ] val show: t -> string end
-module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
-    T with type t = [X.t | Y.t] =
-  struct
-    type t = [X.t | Y.t]
-    let show = function
-        #X.t as x -> X.show x
-      | #Y.t as y -> Y.show y
-  end;;
-module M = Mix(EStr)(EInt);;
-
-(* deep *)
-module M : sig type t = private [> `A] end = struct type t = [`A] end
-module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
-
-(* bad *)
-type t = private [> ]
-type u = private [> `A of int] ~ [t] ;;
-
-(* ok *)
-type t = private [> `A of int]
-type u = private [> `A of int] ~ [t] ;;
-
-module F(X: sig
-  type t = private [> ] ~ [`A;`B;`C;`D]
-  type u = private [> `A|`B|`C] ~ [t; `D]
-end) : sig type v = private [< X.t | X.u | `D] end = struct
-  open X
-  let f = function #u -> 1 | #t -> 2 | `D -> 3
-  let g = function #u|#t|`D -> 2 
-  type v = [t|u|`D]
-end
-
-(* ok *)
-module M = struct type t = private [> `A] end;;
-module M' : sig type t = private [> ] ~ [`A] end = M;;
-
-(* ok *)
-module type T = sig type t = private [> ] ~ [`A] end;;
-module type T' = T with type t = private [> `A];;
-
-(* ok *)
-type t = private [> ] ~ [`A]
-let f = function `A x -> x | #t -> 0
-type t' = private [< `A of int | t];;
-
-(* should be ok *)
-module F(X:sig end) :
-    sig type t = private [> ] type u = private [> ] ~ [t] end =
-  struct type t = [ `A] type u = [`B] end
-module M = F(String)
-let f = function #M.t -> 1 | #M.u -> 2
-let f = function #M.t -> 1 | _ -> 2
-type t = [M.t | M.u]
-let f = function #t -> 1 | _ -> 2;;
-module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) =
-  struct let f = function #X.t -> 1 | _ -> 2 end;;
-module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;;
-module M1 = G(struct type t = M.t type u = M.u end) ;;
-(* bad *)
-let f = function #F(String).t -> 1 | _ -> 2;;
-type t = [F(String).t | M.u]
-let f = function #t -> 1 | _ -> 2;;
-module N : sig type t = private [> ] end =
-  struct type t = [F(String).t | M.u] end;;
-
-(* compatibility improvement *)
-type a = [`A of int | `B]
-type b = [`A of bool | `B]
-type c = private [> ] ~ [a;b]
-let f = function #c -> 1 | `A x -> truncate x
-type d = private [> ] ~ [a]
-let g = function #d -> 1 | `A x -> truncate x;;
-
-
-(* Expression Problem: functorial form *)
-
-type num = [ `Num of int ]
-
-module type Exp = sig
-  type t = private [> num]
-  val eval : t -> t
-  val show : t -> string
-end
-
-module Num(X : Exp) = struct
-  type t = num
-  let eval (`Num _ as x) : X.t = x
-  let show (`Num n) = string_of_int n
-end
-
-type 'a add = [ `Add of 'a * 'a ]
-
-module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
-  type t = X.t add
-  let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
-  let eval (`Add(e1, e2) : t) =
-    let e1 = X.eval e1 and e2 = X.eval e2 in
-    match e1, e2 with
-      `Num n1, `Num n2 -> `Num (n1+n2)
-    | `Num 0, e | e, `Num 0 -> e
-    | e12 -> `Add e12
-end 
-
-type 'a mul = [`Mul of 'a * 'a]
-
-module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
-  type t = X.t mul
-  let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
-  let eval (`Mul(e1, e2) : t) =
-    let e1 = X.eval e1 and e2 = X.eval e2 in
-    match e1, e2 with
-      `Num n1, `Num n2 -> `Num (n1*n2)
-    | `Num 0, e | e, `Num 0 -> `Num 0
-    | `Num 1, e | e, `Num 1 -> e
-    | e12 -> `Mul e12
-end
-
-module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
-  module type S =
-    sig
-      type t = private [> ] ~ [ X.t ]
-      val eval : t -> Y.t
-      val show : t -> string
-    end
-end
-
-module Dummy = struct type t = [`Dummy] end
-
-module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
-  struct
-    type t = [E1.t | E2.t]
-    let eval = function
-        #E1.t as x -> E1.eval x
-      | #E2.t as x -> E2.eval x
-    let show = function
-        #E1.t as x -> E1.show x
-      | #E2.t as x -> E2.show x
-  end
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
-    Mix(EAdd)(Num(EAdd))(Add(EAdd))
-
-(* A bit heavy: one must pass E to everybody *)
-module rec E : Exp with type t = [num | E.t add | E.t mul] =
-    Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))
-
-let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
-
-(* Alternatives *)
-(* Direct approach, no need of Mix *)
-module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
-  struct
-    module E1 = Num(E)
-    module E2 = Add(E)
-    module E3 = Mul(E)
-    type t = E.t
-    let show = function
-      | #num as x -> E1.show x
-      | #add as x -> E2.show x
-      | #mul as x -> E3.show x
-    let eval = function
-      | #num as x -> E1.eval x
-      | #add as x -> E2.eval x
-      | #mul as x -> E3.eval x
-  end
-
-(* Do functor applications in Mix *)
-module type T = sig type t = private [> ] end
-module type Tnum = sig type t = private [> num] end
-
-module Ext(E : Tnum) = struct
-  module type S = functor (Y : Exp with type t = E.t) ->
-    sig
-      type t = private [> num]
-      val eval : t -> Y.t
-      val show : t -> string
-    end
-end
-
-module Ext'(E : Tnum)(X : T) = struct
-  module type S = functor (Y : Exp with type t = E.t) ->
-    sig
-      type t = private [> ] ~ [ X.t ]
-      val eval : t -> Y.t
-      val show : t -> string
-    end
-end
-
-module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
-  struct
-    module E1 = F1(E)
-    module E2 = F2(E)
-    type t = [E1.t | E2.t]
-    let eval = function
-        #E1.t as x -> E1.eval x
-      | #E2.t as x -> E2.eval x
-    let show = function
-        #E1.t as x -> E1.show x
-      | #E2.t as x -> E2.show x
-  end
-
-module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
-    (E' : Exp with type t = E.t) =
-  Mix(E)(F1)(F2)
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
-  Mix(EAdd)(Num)(Add)
-
-module rec EMul : (Exp with type t = [num | EMul.t mul]) =
-  Mix(EMul)(Num)(Mul)
-
-module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
-  Mix(E)(Join(E)(Num)(Add))(Mul)
-
-(* Linear extension by the end: not so nice *)
-module LExt(X : T) = struct
-  module type S =
-    sig
-      type t
-      val eval : t -> X.t
-      val show : t -> string
-    end
-end
-module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
-  struct
-    type t = [num | X.t]
-    let show = function
-        `Num n -> string_of_int n
-      | #X.t as x -> X.show x
-    let eval = function
-        #num as x -> x
-      | #X.t as x -> X.eval x
-  end
-module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
-    (X : LExt(E).S with type t = private [> ] ~ [add]) =
-  struct
-    type t = [E.t add | X.t]
-    let show = function
-        `Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
-      | #X.t as x -> X.show x
-    let eval = function
-        `Add(e1,e2) ->
-          let e1 = E.eval e1 and e2 = E.eval e2 in
-          begin match e1, e2 with
-            `Num n1, `Num n2 -> `Num (n1+n2)
-          | `Num 0, e | e, `Num 0 -> e
-          | e12 -> `Add e12
-          end
-      | #X.t as x -> X.eval x
-  end
-module LEnd = struct
-  type t = [`Dummy]
-  let show `Dummy = ""
-  let eval `Dummy = `Dummy
-end
-module rec L : Exp with type t = [num | L.t add | `Dummy] =
-    LAdd(L)(LNum(L)(LEnd))
-
-(* Back to first form, but add map *)
-
-module Num(X : Exp) = struct
-  type t = num
-  let map f x = x
-  let eval1 (`Num _ as x) : X.t = x
-  let show (`Num n) = string_of_int n
-end
-
-module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
-  type t = X.t add
-  let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
-  let map f (`Add(e1, e2) : t) = `Add(f e1, f e2)
-  let eval1 (`Add(e1, e2) as e : t) =
-    match e1, e2 with
-      `Num n1, `Num n2 -> `Num (n1+n2)
-    | `Num 0, e | e, `Num 0 -> e
-    | _ -> e
-end 
-
-module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
-  type t = X.t mul
-  let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
-  let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2)
-  let eval1 (`Mul(e1, e2) as e : t) =
-    match e1, e2 with
-      `Num n1, `Num n2 -> `Num (n1*n2)
-    | `Num 0, e | e, `Num 0 -> `Num 0
-    | `Num 1, e | e, `Num 1 -> e
-    | _ -> e
-end
-
-module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
-  module type S =
-    sig
-      type t = private [> ] ~ [ X.t ]
-      val map  : (Y.t -> Y.t) -> t -> t
-      val eval1 : t -> Y.t
-      val show : t -> string
-    end
-end
-
-module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
-  struct
-    type t = [E1.t | E2.t]
-    let map f = function
-        #E1.t as x -> (E1.map f x : E1.t :> t)
-      | #E2.t as x -> (E2.map f x : E2.t :> t)
-    let eval1 = function
-        #E1.t as x -> E1.eval1 x
-      | #E2.t as x -> E2.eval1 x
-    let show = function
-        #E1.t as x -> E1.show x
-      | #E2.t as x -> E2.show x
-  end
-
-module type ET = sig
-  type t
-  val map  : (t -> t) -> t -> t
-  val eval1 : t -> t
-  val show : t -> string
-end
-
-module Fin(E : ET) = struct
-  include E
-  let rec eval e = eval1 (map eval e)
-end
-
-module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
-    Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd)))
-
-module rec E : Exp with type t = [num | E.t add | E.t mul] =
-    Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)))
-
-let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))

diff --git a/testsuite/.ignore b/testsuite/.ignore
new file mode 100644 (file)
index 0000000..a333a8b
--- /dev/null
+++ b/testsuite/.ignore
@@ -0,0 +1 @@
+_log

diff --git a/testsuite/.svnignore b/testsuite/.svnignore
deleted file mode 100644 (file)
index 93feea3..0000000
--- a/testsuite/.svnignore
+++ /dev/null
@@ -1,9 +0,0 @@
-# svn propset -R svn:ignore -F .svnignore .
-# find . -name .svnignore -print | while read f; do svn propset svn:ignore -F $f `dirname $f`; done
-_log
-*.so
-*.a
-*.result
-*.byte
-*.native
-program

diff --git a/testsuite/Makefile b/testsuite/Makefile
index d7a975699c2a5786e1175fcf86d6cdcd67fe08e3..497d7403d027e2c447b0c68748c3169d028c06d7 100644 (file)
--- a/testsuite/Makefile
+++ b/testsuite/Makefile
@@ -5,12 +5,13 @@ NO_PRINT=`($(MAKE) empty --no-print-directory > /dev/null 2>&1) && echo '--no-pr
 
 default:
        @echo "Available targets:"
-       @echo "  all           launches all tests"
-       @echo "  list FILE=f   launches the tests referenced in file f (one path per line)"
-       @echo "  one DIR=p     launches the tests located in path p"
-       @echo "  lib           builds library modules"
-       @echo "  clean         deletes generated files"
-       @echo "  report        prints the report for the last execution, if any"
+       @echo "  all             launches all tests"
+       @echo "  list FILE=f     launches the tests referenced in file f (one path per line)"
+       @echo "  one DIR=p       launches the tests located in path p"
+       @echo "  promote DIR=p   promotes the reference files for the tests located in path p"
+       @echo "  lib             builds library modules"
+       @echo "  clean           deletes generated files"
+       @echo "  report          prints the report for the last execution, if any"
 
 all: lib
        @for dir in tests/*; do \
@@ -32,23 +33,29 @@ one: lib
        @$(MAKE) $(NO_PRINT) exec-one DIR=$(DIR)
 
 exec-one:
-       @echo "Running tests from '$$DIR' ..."
-       @(cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) && cd ../..)
+       @if [ ! -f $(DIR)/Makefile ]; then \
+         for dir in $(DIR)/*; do \
+           if [ -d $$dir ]; then \
+             $(MAKE) exec-one DIR=$$dir; \
+           fi; \
+         done; \
+        else \
+         echo "Running tests from '$$DIR' ..."; \
+         (cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR)); \
+       fi
+
+promote: FORCE
+       @if [ -z $(DIR) ]; then echo "No value set for variable 'DIR'."; exit 1; fi
+       @if [ ! -d $(DIR) ]; then echo "Directory '$(DIR)' does not exist."; exit 1; fi
+       @(cd $(DIR) && $(MAKE) TERM=dumb BASEDIR=$(BASEDIR) promote)
 
 lib: FORCE
-       @(cd lib && $(MAKE) -s BASEDIR=$(BASEDIR) && cd ..)
+       @(cd lib && $(MAKE) -s BASEDIR=$(BASEDIR))
 
 clean: FORCE
-       @(cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean && cd ..)
-       @for file in tests/*; do \
-         if [ -d $$file ]; then \
-           (cd $$file && $(MAKE) BASEDIR=$(BASEDIR) clean && cd ../..); \
-         fi \
-       done
-       @for file in interactive/*; do \
-         if [ -d $$file ]; then \
-           (cd $$file && $(MAKE) BASEDIR=$(BASEDIR) clean && cd ../..); \
-         fi \
+       @(cd lib && $(MAKE) BASEDIR=$(BASEDIR) clean)
+       @for file in `find interactive tests -name Makefile`; do \
+         (cd `dirname $$file` && $(MAKE) BASEDIR=$(BASEDIR) clean); \
        done
 
 report: FORCE
@@ -59,6 +66,7 @@ report: FORCE
        @echo '  ' `grep 'failed$$' _log | wc -l` 'test(s) failed'
        @echo '  ' `grep '^Error' _log | wc -l` 'compilation error(s)'
        @echo '  ' `grep '^Warning' _log | wc -l` 'compilation warning(s)'
+       @echo '  ' `grep '^make\[2\]: ' _log | wc -l` 'makefile error(s)'
 
 empty: FORCE
 

diff --git a/testsuite/interactive/lib-gc/Makefile b/testsuite/interactive/lib-gc/Makefile
index 4eb07e7e9f625d9653ffc6d9ec82e291974ba570..65bd44d1f456ff3ac7779b89b3598d655dfdef5e 100644 (file)
--- a/testsuite/interactive/lib-gc/Makefile
+++ b/testsuite/interactive/lib-gc/Makefile
@@ -1,3 +1,5 @@
+BASEDIR=../..
+
 default:
        @$(OCAMLC) -o program.byte alloc.ml
        @./program.byte
@@ -7,4 +9,4 @@ default:
 clean: defaultclean
        @rm -fr program.*
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml
index ea103e42af29a3989c0db1c35433cd6c7304835e..dbcb3e4fda36693ae883261c7985c502a9f86682 100644 (file)
--- a/testsuite/interactive/lib-gc/alloc.ml
+++ b/testsuite/interactive/lib-gc/alloc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Damien Doligez, projet Para, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/interactive/lib-graph-2/Makefile b/testsuite/interactive/lib-graph-2/Makefile
index 6ede5e50bf80c77c7fab18150e9299106175baa4..9a5c0c5f4c7b90d32c1973729aaea0c98bd10b81 100644 (file)
--- a/testsuite/interactive/lib-graph-2/Makefile
+++ b/testsuite/interactive/lib-graph-2/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=graph_test
 #ADD_COMPFLAGS=
 LIBRARIES=graphics
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/interactive/lib-graph-2/graph_test.ml b/testsuite/interactive/lib-graph-2/graph_test.ml
index 217e2fa56f71a1bc988118a9b4ec480a87972f23..6c9fd49ac62dffcc179a1858f4797c96098702e1 100644 (file)
--- a/testsuite/interactive/lib-graph-2/graph_test.ml
+++ b/testsuite/interactive/lib-graph-2/graph_test.ml
@@ -1,13 +1,12 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt          *)
 (*                                                                     *)
 (*  Copyright 2000 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the GNU Library General Public License, with    *)
-(*  the special exception on linking described in file ../../LICENSE.  *)
+(*  under the terms of the Q Public License version 1.0.               *)
 (*                                                                     *)
 (***********************************************************************)
 
@@ -28,7 +27,7 @@ let sz = 450;;
 
 open_graph (Printf.sprintf " %ix%i" sz sz);;
 
-(* To be defined for older versions of O'Caml
+(* To be defined for older versions of OCaml
    Lineto, moveto and draw_rect.
 
 let rlineto x y =
@@ -151,7 +150,7 @@ let x,y = current_point () in
 fill_rect x (y - 5) (8 * 20) 25;;
 set_color yellow;;
 go_legend ();;
-draw_string "Graphics (Caml)";;
+draw_string "Graphics (OCaml)";;
 
 (* Pie parts in different colors. *)
 let draw_green_string s = set_color green; draw_string s;;

diff --git a/testsuite/interactive/lib-graph-3/Makefile b/testsuite/interactive/lib-graph-3/Makefile
index a37aa33d61171a5fd74ced77f7db6d99f063c426..6f0660a991c7b029d916fe6b91b8598d0ddaeec0 100644 (file)
--- a/testsuite/interactive/lib-graph-3/Makefile
+++ b/testsuite/interactive/lib-graph-3/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=sorts
 ADD_COMPFLAGS=-thread
 LIBRARIES=unix threads graphics
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/interactive/lib-graph/Makefile b/testsuite/interactive/lib-graph/Makefile
index be82565857d0f18c3c2bcb8e50909555cf6e0834..61f472b3a6b04c644a644d4c7d5383440e44df0f 100644 (file)
--- a/testsuite/interactive/lib-graph/Makefile
+++ b/testsuite/interactive/lib-graph/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=graph_example
 #ADD_COMPFLAGS=
 LIBRARIES=graphics
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/interactive/lib-signals/Makefile b/testsuite/interactive/lib-signals/Makefile
index 445f9ac701b32c0b6f412c88bc273d97a5ca2cd7..ec22e068620474128831c9e58c5c2cc0bffd59aa 100644 (file)
--- a/testsuite/interactive/lib-signals/Makefile
+++ b/testsuite/interactive/lib-signals/Makefile
@@ -1,3 +1,5 @@
+BASEDIR=../..
+
 default:
        @$(OCAMLC) -o program.byte signals.ml
        @./program.byte
@@ -7,4 +9,4 @@ default:
 clean: defaultclean
        @rm -fr program.*
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/lib/Makefile b/testsuite/lib/Makefile
index 52b50207d47c78da1fb24bb2183d7c66d080ecad..b6fc63c207f83c30296e7c9859ccef0cb3409f95 100644 (file)
--- a/testsuite/lib/Makefile
+++ b/testsuite/lib/Makefile
@@ -1,7 +1,14 @@
 # $Id$
 
-compile: testing.cmi testing.cmo testing.cmx
+compile: compile-targets
+
+promote: defaultpromote
 
 clean: defaultclean
 
 include ../makefiles/Makefile.common
+
+compile-targets: testing.cmi testing.cmo
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         $(MAKE) testing.cmx; \
+       fi

diff --git a/testsuite/lib/testing.ml b/testsuite/lib/testing.ml
index 2015aa1472b50299bbfc5df7ed233c41d6b48b4e..aa8933a7899cc21d55acdefd41c0a6942521c2dd 100644 (file)
--- a/testsuite/lib/testing.ml
+++ b/testsuite/lib/testing.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/lib/testing.mli b/testsuite/lib/testing.mli
index 6f47d2a3e08031da59a63c212719da79462d2d04..18b2ea0376528a3fe417638e3d431a83d578410f 100644 (file)
--- a/testsuite/lib/testing.mli
+++ b/testsuite/lib/testing.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*             Pierre Weis, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common
index a1abd1aab8e4d28e82dc0a3825a0d0b11759691a..983f82c2fcae14200a01db1d250955f9fa679dc7 100644 (file)
--- a/testsuite/makefiles/Makefile.common
+++ b/testsuite/makefiles/Makefile.common
@@ -4,21 +4,28 @@ TOPDIR=$(BASEDIR)/..
 
 include $(TOPDIR)/config/Makefile
 
+DIFF=diff -q
 BOOTDIR=$(TOPDIR)/boot
 OCAMLRUN=$(BOOTDIR)/ocamlrun$(EXE)
-OCAML=$(OCAMLRUN) $(TOPDIR)/ocaml$(EXE)
-OCAMLC=$(OCAMLRUN) $(TOPDIR)/ocamlc$(EXE)
-OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt$(EXE)
+OCAML=$(OCAMLRUN) $(TOPDIR)/ocaml$(EXE) -I $(TOPDIR)/stdlib
+OCAMLC=$(OCAMLRUN) $(TOPDIR)/ocamlc$(EXE) -I $(TOPDIR)/stdlib
+OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt$(EXE) -I $(TOPDIR)/stdlib
 OCAMLDOC=$(OCAMLRUN) $(TOPDIR)/ocamldoc/ocamldoc$(EXE)
 OCAMLLEX=$(OCAMLRUN) $(TOPDIR)/lex/ocamllex$(EXE)
 OCAMLMKLIB=$(OCAMLRUN) $(TOPDIR)/tools/ocamlmklib$(EXE)
 OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE)
 OCAMLBUILD=$(TOPDIR)/_build/ocamlbuild/ocamlbuild.native
 DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj$(EXE)
+BYTECODE_ONLY=`if [ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]; then echo 'YES'; else echo ''; fi`
 #COMPFLAGS=
 #FORTRAN_COMPILER=
 #FORTRAN_LIBRARY=
 
+defaultpromote:
+       @for file in *.reference; do \
+         cp `basename $$file reference`result $$file; \
+       done
+
 defaultclean:
        @rm -f *.cmo *.cmi *.cmx *.cma *.cmxa *.cmxs *.$(O) *.$(SO) *.$(A)
        @for dsym in *.dSYM; do \

diff --git a/testsuite/makefiles/Makefile.okbad b/testsuite/makefiles/Makefile.okbad
index 833cfab374c23fe99740a62c36477ccfdd87e70a..9016dab3fe84189d1b7492ec887a68cae6538469 100644 (file)
--- a/testsuite/makefiles/Makefile.okbad
+++ b/testsuite/makefiles/Makefile.okbad
@@ -10,10 +10,12 @@ compile:
          else \
            test -f `basename $$file ml`mli && $(OCAMLC) -c -w a `basename $$file ml`mli; \
            $(OCAMLC) -c -w a $$file 2> /dev/null || (echo " => failed" && exit 1); \
-           test -f `basename $$file ml`reference && $(OCAMLC) `basename $$file ml`cmo && ./a.out > `basename $$file ml`result && (diff -q `basename $$file ml`reference `basename $$file ml`result || (echo " => failed" && exit 1)); \
+           test -f `basename $$file ml`reference && $(OCAMLC) `basename $$file ml`cmo && ./a.out > `basename $$file ml`result && ($(DIFF) `basename $$file ml`reference `basename $$file ml`result || (echo " => failed" && exit 1)); \
            echo " => passed"; \
          fi; \
        done
 
+promote: defaultpromote
+
 clean: defaultclean
        @rm -f ./a.out *.cm* *.result

diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one
index 4921d7df10c46972996406542d3f5415efed894b..ca07bf16da726e719745610da134149ba68854e5 100644 (file)
--- a/testsuite/makefiles/Makefile.one
+++ b/testsuite/makefiles/Makefile.one
@@ -25,16 +25,22 @@ compile: $(ML_FILES) $(CMO_FILES) $(CMX_FILES) $(MAIN_MODULE).cmo $(MAIN_MODULE)
          $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(TOPDIR)/byterun $$file.c; \
        done;
        @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) $(MAIN_MODULE).cmo
-       @$(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx; \
+       fi
 
 run:
        @printf " ... testing with ocamlc"
        @./program.byte $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1)
-       @diff -q $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1)
-       @printf " ocamlopt"
-       @./program.native $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1)
-       @diff -q $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1)
+       @$(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1)
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         printf " ocamlopt"; \
+         ./program.native $(EXEC_ARGS) > $(MAIN_MODULE).result || (echo " => failed" && exit 1); \
+         $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result > /dev/null || (echo " => failed" && exit 1); \
+       fi
        @echo " => passed"
 
+promote: defaultpromote
+
 clean: defaultclean
        @rm -f *.result ./program.* $(GENERATED_SOURCES) $(O_FILES)

diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several
index 099251321fdcd6aa8d3c784f0b1358f1b0876f66..e5bd430a1ca8f4360d6c24b5363e6c5a1dcd2dff 100644 (file)
--- a/testsuite/makefiles/Makefile.several
+++ b/testsuite/makefiles/Makefile.several
@@ -26,11 +26,15 @@ run-all:
        done;
        @for file in *.ml; do \
          printf " ... testing '$$file':"; \
-         $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) -w a $(CMA_FILES) -I ../../lib $(CMO_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) && \
-         $(MAKE) run-file DESC=ocamlopt COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_OPTFLAGS) $(O_FILES) -w a $(CMXA_FILES) -I ../../lib $(CMX_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) && \
+         $(MAKE) run-file DESC=ocamlc COMP='$(OCAMLC)' COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_CFLAGS) $(O_FILES) -w a $(CMA_FILES) -I $(BASEDIR)/lib $(CMO_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS) && \
+         if [ -z "$(BYTECODE_ONLY)" ]; then \
+           $(MAKE) run-file DESC=ocamlopt COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='$(ADD_COMPFLAGS) $(ADD_OPTFLAGS) $(O_FILES) -w a $(CMXA_FILES) -I $(BASEDIR)/lib $(CMX_FILES)' FILE=$$file PROGRAM_ARGS=$(PROGRAM_ARGS); \
+         fi && \
          if [ ! -z $(UNSAFE) ]; then \
-           $(MAKE) run-file DESC=ocamlc-unsafe COMP=$(PREFIX)/bin/ocamlc COMPFLAGS='-w a -unsafe -I ../../li $(CMO_FILES)' FILE=$$file && \
-           $(MAKE) run-file DESC=ocamlopt-unsafe COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='-w a -unsafe -I ../../lib $(CMX_FILES)' FILE=$$file; \
+           $(MAKE) run-file DESC=ocamlc-unsafe COMP=$(PREFIX)/bin/ocamlc COMPFLAGS='-w a -unsafe -I $(BASEDIR)/lib $(CMO_FILES)' FILE=$$file && \
+           if [ -z "$(BYTECODE_ONLY)" ]; then \
+             $(MAKE) run-file DESC=ocamlopt-unsafe COMP=$(PREFIX)/bin/ocamlopt COMPFLAGS='-w a -unsafe -I $(BASEDIR)/lib $(CMX_FILES)' FILE=$$file; \
+           fi; \
          fi && \
          echo " => passed"; \
        done;
@@ -46,8 +50,10 @@ run-file:
        @if [ -f `basename $(FILE) ml`checker ]; then \
          sh `basename $(FILE) ml`checker; \
        else \
-         diff -q `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null || (echo " => failed" && exit 1); \
+         $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null || (echo " => failed" && exit 1); \
        fi
 
+promote: defaultpromote
+
 clean: defaultclean
        @rm -f *.result ./program

diff --git a/testsuite/makefiles/Makefile.toplevel b/testsuite/makefiles/Makefile.toplevel
index 2302b1961ac117a68273f36e6236e45c93042e74..532763f431c9449f58fa2e74ec85d42657893e3b 100644 (file)
--- a/testsuite/makefiles/Makefile.toplevel
+++ b/testsuite/makefiles/Makefile.toplevel
@@ -2,15 +2,17 @@
 
 default:
        @for file in *.ml; do \
-         $(OCAML) < $$file 2>&1 | grep -v '^        Objective Caml version' > $$file.result; \
+         $(OCAML) < $$file 2>&1 | grep -v '^        OCaml version' > $$file.result; \
          if [ -f $$file.principal.reference ]; then \
-           $(OCAML) -principal < $$file 2>&1 | grep -v '^        Objective Caml version' > $$file.principal.result; \
+           $(OCAML) -principal < $$file 2>&1 | grep -v '^        OCaml version' > $$file.principal.result; \
          fi; \
        done
        @for file in *.reference; do \
          printf " ... testing '$$file':"; \
-         diff -q $$file `basename $$file reference`result || (echo " => failed" && exit 1) && echo " => passed"; \
+         $(DIFF) $$file `basename $$file reference`result || (echo " => failed" && exit 1) && echo " => passed"; \
        done
 
+promote: defaultpromote
+
 clean: defaultclean
        @rm -f *.result

diff --git a/testsuite/tests/asmcomp/.ignore b/testsuite/tests/asmcomp/.ignore
new file mode 100644 (file)
index 0000000..321dc06
--- /dev/null
+++ b/testsuite/tests/asmcomp/.ignore
@@ -0,0 +1,7 @@
+codegen
+parsecmm.ml
+parsecmm.mli
+lexcmm.ml
+*.s
+*.out
+*.out.dSYM

diff --git a/testsuite/tests/asmcomp/.svnignore b/testsuite/tests/asmcomp/.svnignore
deleted file mode 100755 (executable)
index dcb3b20..0000000
--- a/testsuite/tests/asmcomp/.svnignore
+++ /dev/null
@@ -1,17 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-*.s
-*.out
-*.dSYM
-parsecmm.mli
-parsecmm.ml
-lexcmm.ml
-codegen
-
-EOF

diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile
index 583680deac2732726ff86096c3b449fb98e1a2f8..2161b856e45ff9386b7b144d743e59be65ff8c0a 100644 (file)
--- a/testsuite/tests/asmcomp/Makefile
+++ b/testsuite/tests/asmcomp/Makefile
@@ -1,3 +1,4 @@
+BASEDIR=../..
 CC=$(NATIVECC)
 CFLAGS=$(NATIVECCCOMPOPTS) -g
 
@@ -16,7 +17,6 @@ OTHEROBJS=\
   $(TOPDIR)/utils/ccomp.cmo \
   $(TOPDIR)/utils/warnings.cmo \
   $(TOPDIR)/utils/consistbl.cmo \
-  $(TOPDIR)/parsing/linenum.cmo \
   $(TOPDIR)/parsing/location.cmo \
   $(TOPDIR)/parsing/longident.cmo \
   $(TOPDIR)/parsing/syntaxerr.cmo \
@@ -24,7 +24,6 @@ OTHEROBJS=\
   $(TOPDIR)/parsing/lexer.cmo \
   $(TOPDIR)/parsing/parse.cmo \
   $(TOPDIR)/parsing/printast.cmo \
-  $(TOPDIR)/typing/unused_var.cmo \
   $(TOPDIR)/typing/ident.cmo \
   $(TOPDIR)/typing/path.cmo \
   $(TOPDIR)/typing/primitive.cmo \
@@ -94,7 +93,12 @@ OBJS=parsecmmaux.cmo parsecmm.cmo lexcmm.cmo
 
 ADD_COMPFLAGS=$(INCLUDES) -g
 
-default: arch codegen tests
+default:
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         $(MAKE) all; \
+       fi
+
+all: arch codegen tests
 
 codegen: parsecmm.ml lexcmm.ml $(OBJS:.cmo=.cmi) $(OBJS) main.cmo
        @$(OCAMLC) $(LINKFLAGS) -o codegen $(OTHEROBJS) $(OBJS) main.cmo
@@ -138,7 +142,8 @@ clean: defaultclean
 power.o: power-$(SYSTEM).o
        @cp power-$(SYSTEM).o power.o
 
+promote:
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common
 
 arch: $(ARCH).o

diff --git a/testsuite/tests/asmcomp/alpha.S b/testsuite/tests/asmcomp/alpha.S
index d8851065c330a9850dd19440dac73ab29acbfda8..10e33886374f58f47047ae59d4e122b36de12fbc 100644 (file)
--- a/testsuite/tests/asmcomp/alpha.S
+++ b/testsuite/tests/asmcomp/alpha.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/asmcomp/amd64.S b/testsuite/tests/asmcomp/amd64.S
index 8df6e2d20dbf88fb86022f9f94865fdaac5dffbc..26db8722a969954a411c472eecb046f1cc89e2d4 100644 (file)
--- a/testsuite/tests/asmcomp/amd64.S
+++ b/testsuite/tests/asmcomp/amd64.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/asmcomp/arith.cmm b/testsuite/tests/asmcomp/arith.cmm
index f4efefdbefff1aec111e0afac4b2e95c4303627d..a8bc613c77e2e33583d2ee0c1ff6e6c508124ad0 100644 (file)
--- a/testsuite/tests/asmcomp/arith.cmm
+++ b/testsuite/tests/asmcomp/arith.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/arm.S b/testsuite/tests/asmcomp/arm.S
index 186d7061460805151f45aaf002287ef5fb7935d1..0fd1a29fe6660723a5c6217e881778c758b82267 100644 (file)
--- a/testsuite/tests/asmcomp/arm.S
+++ b/testsuite/tests/asmcomp/arm.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/asmcomp/checkbound.cmm b/testsuite/tests/asmcomp/checkbound.cmm
index 995b74f8a3c71e7be88bd8a12484be3ee4dba3d4..c20740c113f7ca23646845b3c341a67155c7a2ee 100644 (file)
--- a/testsuite/tests/asmcomp/checkbound.cmm
+++ b/testsuite/tests/asmcomp/checkbound.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/fib.cmm b/testsuite/tests/asmcomp/fib.cmm
index b7e64d3025e60bbcdcad4bea3517dfb100c54860..d21260448b062a7e65c1a8d7356f1de1aa80dc69 100644 (file)
--- a/testsuite/tests/asmcomp/fib.cmm
+++ b/testsuite/tests/asmcomp/fib.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/hppa.S b/testsuite/tests/asmcomp/hppa.S
index 2b1ab21c66ece492bd65de007dc13e66c48ed4d6..02f457dc75ac94ede75673f95e36820a8d6e01c0 100644 (file)
--- a/testsuite/tests/asmcomp/hppa.S
+++ b/testsuite/tests/asmcomp/hppa.S
@@ -1,6 +1,6 @@
 ;*********************************************************************
 ;*                                                                   *
-;*                          Objective Caml                           *
+;*                               OCaml                               *
 ;*                                                                   *
 ;*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        *
 ;*                                                                   *

diff --git a/testsuite/tests/asmcomp/i386.S b/testsuite/tests/asmcomp/i386.S
index f4b65e57ac29b26350e848c1ca896cd07055d1f7..fc75b1f1f8157083d92c27928654a59f383d925a 100644 (file)
--- a/testsuite/tests/asmcomp/i386.S
+++ b/testsuite/tests/asmcomp/i386.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/asmcomp/i386nt.asm b/testsuite/tests/asmcomp/i386nt.asm
index 66550eb8b21107fc16da257f8db2f3142834e9dc..75ae8ce737db9683c9185d6876c7426f17ab6796 100644 (file)
--- a/testsuite/tests/asmcomp/i386nt.asm
+++ b/testsuite/tests/asmcomp/i386nt.asm
@@ -1,6 +1,6 @@
 ;*********************************************************************
 ;                                                                     
-;                           Objective Caml                            
+;                                OCaml                                
 ;                                                                     
 ;            Xavier Leroy, projet Cristal, INRIA Rocquencourt         
 ;                                                                     

diff --git a/testsuite/tests/asmcomp/ia64.S b/testsuite/tests/asmcomp/ia64.S
index 51361690b899ba811476b4b0315a5281e68fdaa1..028c622f9d31551b87c76582f5d62a27822c5985 100644 (file)
--- a/testsuite/tests/asmcomp/ia64.S
+++ b/testsuite/tests/asmcomp/ia64.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -26,7 +26,7 @@
         .proc   call_gen_code#
 
 call_gen_code:
-        /* Allocate 64 "out" registers (for the Caml code) and no locals */
+        /* Allocate 64 "out" registers (for the OCaml code) and no locals */
         alloc   r3 = ar.pfs, 0, 0, 64, 0
 
         /* Save PFS, return address and GP on stack */

diff --git a/testsuite/tests/asmcomp/integr.cmm b/testsuite/tests/asmcomp/integr.cmm
index 481dd7587df3d6142c29c2f60ec633d511ca86e2..504bb0db5a146084e61affc7b466281d1db364ee 100644 (file)
--- a/testsuite/tests/asmcomp/integr.cmm
+++ b/testsuite/tests/asmcomp/integr.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/lexcmm.mli b/testsuite/tests/asmcomp/lexcmm.mli
index a28a57c520da85d7950500513f2e962b29bf5354..a4998ca1274c75bd2528a539136da115d487aa98 100644 (file)
--- a/testsuite/tests/asmcomp/lexcmm.mli
+++ b/testsuite/tests/asmcomp/lexcmm.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll
index 0e8432e1c828636e4bfec956192c4b481b770535..eb2f2c8296f99260bcb56383d028e0d5ebcbea85 100644 (file)
--- a/testsuite/tests/asmcomp/lexcmm.mll
+++ b/testsuite/tests/asmcomp/lexcmm.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/m68k.S b/testsuite/tests/asmcomp/m68k.S
index 436e65e6958b5f28a090b44043962252200daae1..f15ddcbb40915b9c458bdb44f32973190793d800 100644 (file)
--- a/testsuite/tests/asmcomp/m68k.S
+++ b/testsuite/tests/asmcomp/m68k.S
@@ -1,6 +1,6 @@
 |***********************************************************************
 |*                                                                     *
-|*                           Objective Caml                            *
+|*                                OCaml                                *
 |*                                                                     *
 |*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *
 |*                                                                     *

diff --git a/testsuite/tests/asmcomp/main.c b/testsuite/tests/asmcomp/main.c
index e45c8c27c3f9b8714195cdeb8a275e590c060da0..33fd8a98a48e5452eff5c537a532cebc4e9ebd4a 100644 (file)
--- a/testsuite/tests/asmcomp/main.c
+++ b/testsuite/tests/asmcomp/main.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml
index d6207102ace7ce90eb998e218659c73530b1e5e7..0555daed8d9d8f52c1fa3f7d61924d263f7a12d9 100644 (file)
--- a/testsuite/tests/asmcomp/main.ml
+++ b/testsuite/tests/asmcomp/main.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c
index 95a923d8b94245e8ae1e5783cd44835944a809aa..a71be4961cf25624f89a62f198783dcc9bb7aebe 100644 (file)
--- a/testsuite/tests/asmcomp/mainarith.c
+++ b/testsuite/tests/asmcomp/mainarith.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/asmcomp/mips.s b/testsuite/tests/asmcomp/mips.s
index 9fe9f94b60a39191e16bbb5dfbe1dc6eed4c1ee3..ec6931bf7199cf67c9fc7ab86c20ae20e208c80e 100644 (file)
--- a/testsuite/tests/asmcomp/mips.s
+++ b/testsuite/tests/asmcomp/mips.s
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly
index 79b278b0520851e542d2af92201d581661a4c816..b0aeec879fdb4b92da5789961ec4de076c4ba66d 100644 (file)
--- a/testsuite/tests/asmcomp/parsecmm.mly
+++ b/testsuite/tests/asmcomp/parsecmm.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -149,7 +149,8 @@ phrase:
 fundecl:
     LPAREN FUNCTION STRING LPAREN params RPAREN sequence RPAREN
       { List.iter (fun (id, ty) -> unbind_ident id) $5;
-        {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true} }
+        {fun_name = $3; fun_args = $5; fun_body = $7; fun_fast = true;
+         fun_dbg = Debuginfo.none} }
 ;
 params:
     oneparam params     { $1 :: $2 }

diff --git a/testsuite/tests/asmcomp/parsecmmaux.ml b/testsuite/tests/asmcomp/parsecmmaux.ml
index 8c46888c6b67683e40470d9be5ce669a80154c22..5aa2ea05b5d8c2084f17d38bc482be2a9d5334d2 100644 (file)
--- a/testsuite/tests/asmcomp/parsecmmaux.ml
+++ b/testsuite/tests/asmcomp/parsecmmaux.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/parsecmmaux.mli b/testsuite/tests/asmcomp/parsecmmaux.mli
index 558996552c594ca38f6ce7b61d14125bd53a2ad8..d488db1f5d19cd5b8a4c229890f73a80a13f00db 100644 (file)
--- a/testsuite/tests/asmcomp/parsecmmaux.mli
+++ b/testsuite/tests/asmcomp/parsecmmaux.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/power-aix.S b/testsuite/tests/asmcomp/power-aix.S
index 96ed2b92d19d10ff312c24cd13fb9c424c279927..0752100f59929fac11d7903a87913cd91130a757 100644 (file)
--- a/testsuite/tests/asmcomp/power-aix.S
+++ b/testsuite/tests/asmcomp/power-aix.S
@@ -1,6 +1,6 @@
 #*********************************************************************
 #*                                                                   *
-#*                          Objective Caml                           *
+#*                               OCaml                               *
 #*                                                                   *
 #*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        *
 #*                                                                   *
@@ -123,7 +123,7 @@
         .globl  .caml_c_call
 .caml_c_call:
 # Preserve RTOC and return address in callee-save registers
-# The C function will preserve them, and the Caml code does not
+# The C function will preserve them, and the OCaml code does not
 # expect them to be preserved
 # Return address is in 25, RTOC is in 26
         mflr    25

diff --git a/testsuite/tests/asmcomp/power-elf.S b/testsuite/tests/asmcomp/power-elf.S
index 994a9fa7bed1c7845f06a6d7b8360b20ac6fa9ce..7fee4aa1bf4db34463717c03330ad8e3f479e184 100644 (file)
--- a/testsuite/tests/asmcomp/power-elf.S
+++ b/testsuite/tests/asmcomp/power-elf.S
@@ -1,6 +1,6 @@
 /*********************************************************************/
 /*                                                                   */
-/*                          Objective Caml                           */
+/*                               OCaml                               */
 /*                                                                   */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        */
 /*                                                                   */

diff --git a/testsuite/tests/asmcomp/power-rhapsody.S b/testsuite/tests/asmcomp/power-rhapsody.S
index b456105862cb51e37e1af63696c379f5e4a65ddf..06788a8c47765670ea553fea951b0e4da0da309e 100644 (file)
--- a/testsuite/tests/asmcomp/power-rhapsody.S
+++ b/testsuite/tests/asmcomp/power-rhapsody.S
@@ -1,6 +1,6 @@
 /*********************************************************************/
 /*                                                                   */
-/*                          Objective Caml                           */
+/*                               OCaml                               */
 /*                                                                   */
 /*           Xavier Leroy, projet Cristal, INRIA Rocquencourt        */
 /*                                                                   */

diff --git a/testsuite/tests/asmcomp/quicksort.cmm b/testsuite/tests/asmcomp/quicksort.cmm
index 4029da8d152e7136f2d5807842fc7221b00c4cdf..21b1add57096c4e96cdf7aa362a5c00abf69c8d5 100644 (file)
--- a/testsuite/tests/asmcomp/quicksort.cmm
+++ b/testsuite/tests/asmcomp/quicksort.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/quicksort2.cmm b/testsuite/tests/asmcomp/quicksort2.cmm
index eae9809a79a4f95cd3907300c0ba6c88492d98ba..08988573afd3c2889f2eaa3bdd11b42f87dd9008 100644 (file)
--- a/testsuite/tests/asmcomp/quicksort2.cmm
+++ b/testsuite/tests/asmcomp/quicksort2.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/soli.cmm b/testsuite/tests/asmcomp/soli.cmm
index 47ce64c0b5bf8f1b6a629f4db82fe61993b22547..af4d39fc6ad0724cdc80df1d6b493a8dde3d0427 100644 (file)
--- a/testsuite/tests/asmcomp/soli.cmm
+++ b/testsuite/tests/asmcomp/soli.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S
index 9a829e1732d797f1c20b7f23e055cf54f96e1810..5f83bf0f220130f2ec1920596e39c267fd64970e 100644 (file)
--- a/testsuite/tests/asmcomp/sparc.S
+++ b/testsuite/tests/asmcomp/sparc.S
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/asmcomp/tagged-fib.cmm b/testsuite/tests/asmcomp/tagged-fib.cmm
index e5e45b0fbf299f25ff726a403eb746a38e753090..5ee234d9fffb58bcc1b7f97e07549e6ab0832433 100644 (file)
--- a/testsuite/tests/asmcomp/tagged-fib.cmm
+++ b/testsuite/tests/asmcomp/tagged-fib.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/tagged-integr.cmm b/testsuite/tests/asmcomp/tagged-integr.cmm
index df46813eb9a20aadfc3f023e88ee864077cb465e..6f7562878ea116025964e8f13a2c3a6c6b00e103 100644 (file)
--- a/testsuite/tests/asmcomp/tagged-integr.cmm
+++ b/testsuite/tests/asmcomp/tagged-integr.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/tagged-quicksort.cmm b/testsuite/tests/asmcomp/tagged-quicksort.cmm
index b519e5cef9222158e76ff3a815e7431b42f3ecea..73fca1017107025cf64182971abf6886974ef4dd 100644 (file)
--- a/testsuite/tests/asmcomp/tagged-quicksort.cmm
+++ b/testsuite/tests/asmcomp/tagged-quicksort.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/tagged-tak.cmm b/testsuite/tests/asmcomp/tagged-tak.cmm
index fe9e6eb026e353d735d0471ccd265cc4c865d196..2bda22385ec05ffaac63fe55d668702b17b999d9 100644 (file)
--- a/testsuite/tests/asmcomp/tagged-tak.cmm
+++ b/testsuite/tests/asmcomp/tagged-tak.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/asmcomp/tak.cmm b/testsuite/tests/asmcomp/tak.cmm
index cd61ec89be51241e5d6a0337927d39468ed22cb7..26bbd96817cbaa68525466c2a6c198e35f3c5262 100644 (file)
--- a/testsuite/tests/asmcomp/tak.cmm
+++ b/testsuite/tests/asmcomp/tak.cmm
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile
index 68d042af049f9905cca8c6a4ff7bef084d745cfb..0d368bfc1f479eedbb4e00f2abe0c09f42db98dc 100644 (file)
--- a/testsuite/tests/backtrace/Makefile
+++ b/testsuite/tests/backtrace/Makefile
@@ -1,3 +1,4 @@
+BASEDIR=../..
 EXECNAME=./program
 
 run-all:
@@ -6,11 +7,13 @@ run-all:
          for arg in a b c d ''; do \
            printf " ... testing '$$file' (with argument '$$arg'):"; \
            OCAMLRUNPARAM=b=1 $(EXECNAME) $$arg > `basename $$file ml`$$arg.result 2>&1; \
-           diff -q `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+           $(DIFF) `basename $$file ml`$$arg.reference `basename $$file ml`$$arg.result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
          done; \
        done
 
+promote: defaultpromote
+
 clean: defaultclean
        @rm -f *.result $(EXECNAME)
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-float/Makefile b/testsuite/tests/basic-float/Makefile
index 627ed788485d2fd93ef0c919eb07dc622fd1e58d..dbe9b4dfe7efef45a4342ccb6436b778665d43ae 100644 (file)
--- a/testsuite/tests/basic-float/Makefile
+++ b/testsuite/tests/basic-float/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 MODULES=float_record
 MAIN_MODULE=tfloat_record
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-io-2/Makefile b/testsuite/tests/basic-io-2/Makefile
index 9a7d2ba00e8cbb47cbc1bdd3c228fdd2070fd300..a5829bd15ad6daefe36e6d0ed6026704e413fbeb 100644 (file)
--- a/testsuite/tests/basic-io-2/Makefile
+++ b/testsuite/tests/basic-io-2/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=io
 EXEC_ARGS=io.ml
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-io/Makefile b/testsuite/tests/basic-io/Makefile
index b0edfabbb0508a823266d5e952b3e63764434d9d..ac99445b7ac90f7db89d8b970102cd2ecef42d20 100644 (file)
--- a/testsuite/tests/basic-io/Makefile
+++ b/testsuite/tests/basic-io/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=wc
 EXEC_ARGS=wc.ml
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-manyargs/Makefile b/testsuite/tests/basic-manyargs/Makefile
index ef8a4f546b1136efa19344e5009c6176bc2f514f..d84fc9baaa74ba7986ae0ce96924b8ece762b4fd 100644 (file)
--- a/testsuite/tests/basic-manyargs/Makefile
+++ b/testsuite/tests/basic-manyargs/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=manyargs
 C_FILES=manyargsprim
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-more/Makefile b/testsuite/tests/basic-more/Makefile
index 18f9c9b2cf885c6b3dda538f9da9240b2c6fe94e..329d67de830eb005a5df735a071a779fad32325e 100644 (file)
--- a/testsuite/tests/basic-more/Makefile
+++ b/testsuite/tests/basic-more/Makefile
@@ -1,4 +1,5 @@
+BASEDIR=../..
 MODULES=testing
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-more/testrandom.ml b/testsuite/tests/basic-more/testrandom.ml
index 150d408898a92e8af4e20b0b4d80ee3af0ad3db5..af0e3a2f417e305c55dac238a2736b0769369db3 100644 (file)
--- a/testsuite/tests/basic-more/testrandom.ml
+++ b/testsuite/tests/basic-more/testrandom.ml
@@ -1,13 +1,12 @@
 open Random
 
-let _ = 
+let _ =
   for i = 0 to 20 do
-    print_float (float 1000.); print_char ' '
+    print_int (int 1000); print_char ' '
   done;
   print_newline ();  print_newline ();
   for i = 0 to 20 do
-    print_int (int 1000); print_char ' '
+    print_float (float 1000.); print_char ' '
   done
 
 let _ = exit 0
-

diff --git a/testsuite/tests/basic-more/testrandom.reference b/testsuite/tests/basic-more/testrandom.reference
index f063674d904519e4eb57c4f1e7a80ef58f270625..366e682c15b311ebd949866863c23ee305d74b37 100644 (file)
--- a/testsuite/tests/basic-more/testrandom.reference
+++ b/testsuite/tests/basic-more/testrandom.reference
@@ -1,4 +1,4 @@
-270.251355065 597.822945853 287.052171181 625.315015859 241.029649126 559.742196387 932.074421229 756.637587326 360.006556146 987.177314953 190.217751234 758.516786217 59.8488223602 328.350439075 172.627051105 944.543207513 629.424106752 868.196647048 174.382120878 78.1259713643 34.3270777955 
+344 685 182 641 439 500 104 20 921 370 217 885 949 678 615 412 401 606 428 869 289 
 
-683 782 740 270 835 136 791 168 324 222 156 835 328 636 233 153 671 69 95 357 92 
+122.128067547 461.324792129 360.006556146 768.75882284 396.500946942 190.217751234 567.660068681 403.59226778 59.8488223602 363.816246826 764.705761642 172.627051105 481.861849093 399.173195422 629.424106752 391.547032203 676.701133948 174.382120878 994.425675487 585.00027757 34.3270777955 
 All tests succeeded.

diff --git a/testsuite/tests/basic-more/tformat.ml b/testsuite/tests/basic-more/tformat.ml
index d02cb2907ae0270f19f3ca584cdda9eff4a8b3ae..77d30ac34d71dca19458cf535ac2144dc4071b72 100644 (file)
--- a/testsuite/tests/basic-more/tformat.ml
+++ b/testsuite/tests/basic-more/tformat.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                            Objective Caml                             *)
+(*                                 OCaml                                 *)
 (*                                                                       *)
 (*            Pierre Weis, projet Estime, INRIA Rocquencourt             *)
 (*                                                                       *)

diff --git a/testsuite/tests/basic-multdef/Makefile b/testsuite/tests/basic-multdef/Makefile
index 79660b57fdfecb8fa2a4b223ec5c89762a77e7fc..5ec6aff73189a7464ac5221d24fd84b6ce9f7dca 100644 (file)
--- a/testsuite/tests/basic-multdef/Makefile
+++ b/testsuite/tests/basic-multdef/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 MODULES=multdef
 MAIN_MODULE=usemultdef
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic-private/Makefile b/testsuite/tests/basic-private/Makefile
index 99475d0f3840edcba68b0e6cc019a3bab5529e71..06c5591cc34683391aae3bd1d450d6d06b1af112 100644 (file)
--- a/testsuite/tests/basic-private/Makefile
+++ b/testsuite/tests/basic-private/Makefile
@@ -1,5 +1,7 @@
+BASEDIR=../..
+
 MODULES=length
 MAIN_MODULE=tlength
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic/Makefile b/testsuite/tests/basic/Makefile
index a226dd11fc1d32b20b703928752d25a6a5fb3f42..4ba0bffc51a49617bbbe56f5150b18b6313711fa 100644 (file)
--- a/testsuite/tests/basic/Makefile
+++ b/testsuite/tests/basic/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml
index bbe8be32795b27208656f1576fe02cc1b0b69b83..8dcf116623b8b66e5f97a15221238008355b582b 100644 (file)
--- a/testsuite/tests/basic/arrays.ml
+++ b/testsuite/tests/basic/arrays.ml
@@ -46,7 +46,9 @@ let test2 () =
   if not (testcopy [|1.2;2.3;3.4;4.5|]) then
     print_string "Test2: failed on float array\n";
   if not (testcopy [|"un"; "deux"; "trois"|]) then
-    print_string "Test2: failed on string array\n"
+    print_string "Test2: failed on string array\n";
+  if not (testcopy (bigarray 42)) then
+    print_string "Test2: failed on big array\n"
 
 module AbstractFloat =
   (struct
@@ -79,8 +81,41 @@ let test3 () =
           AbstractFloat.to_float u.(2) = 3.0) then
     print_string "Test3: failed on u\n"
 
+let test4 () =
+  let a = bigarray 0 in
+  let b = Array.sub a 50 10 in
+  if b <> [| 50;51;52;53;54;55;56;57;58;59 |] then
+    print_string "Test4: failed\n"
+
+let test5 () =
+  if Array.append [| 1;2;3 |] [| 4;5 |] <> [| 1;2;3;4;5 |] then
+    print_string "Test5: failed on int arrays\n";
+  if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |] then
+    print_string "Test5: failed on float arrays\n"
+
+let test6 () =
+  let a = [| 0;1;2;3;4;5;6;7;8;9 |] in
+  let b = Array.concat [a;a;a;a;a;a;a;a;a;a] in
+  if not (Array.length b = 100 && b.(6) = 6 && b.(42) = 2 && b.(99) = 9) then
+    print_string "Test6: failed\n"
+
+let test7 () =
+  let a = Array.make 10 "a" in
+  let b = [| "b1"; "b2"; "b3" |] in
+  Array.blit b 0 a 5 3;
+  if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b2"; "b3"; "a"; "a"|]
+  || b <> [|"b1"; "b2"; "b3"|]
+  then print_string "Test7: failed(1)\n";
+  Array.blit a 5 a 6 4;
+  if a <> [|"a"; "a"; "a"; "a"; "a"; "b1"; "b1"; "b2"; "b3"; "a"|]
+  then print_string "Test7: failed(2)\n"
+
 let _ =
   test1();
   test2();
   test3();
+  test4();
+  test5();
+  test6();
+  test7();
   exit 0

diff --git a/testsuite/tests/basic/boxedints.ml b/testsuite/tests/basic/boxedints.ml
index 19574a1a4be3648dd7ba9861f3a87b7be99b1e67..6dd1773dcc169f14c111e11469bc97e2e9546d6b 100644 (file)
--- a/testsuite/tests/basic/boxedints.ml
+++ b/testsuite/tests/basic/boxedints.ml
@@ -166,6 +166,7 @@ struct
        9, 127531236, -365;
        10, 1234567, 12345678;
        11, 1234567, -12345678];
+    test 12 (div min_int (of_int (-1))) min_int;
 
     testing_function "mod";
     List.iter
@@ -181,6 +182,7 @@ struct
        9, 127531236, -365;
        10, 1234567, 12345678;
        11, 1234567, -12345678];
+    test 12 (rem min_int (of_int (-1))) (of_int 0);
 
     testing_function "and";
     List.iter
@@ -400,6 +402,7 @@ struct
        9, 127531236, -365;
        10, 1234567, 12345678;
        11, 1234567, -12345678];
+    test 12 (div min_int (of_int (-1))) min_int;
 
     testing_function "mod";
     List.iter
@@ -415,6 +418,7 @@ struct
        9, 127531236, -365;
        10, 1234567, 12345678;
        11, 1234567, -12345678];
+    test 12 (rem min_int (of_int (-1))) (of_int 0);
 
     testing_function "and";
     List.iter

diff --git a/testsuite/tests/basic/boxedints.reference b/testsuite/tests/basic/boxedints.reference
index fe08bb2b8137f1c8ed8808d858e219e544ff870a..009390faeede7f0c5c64d789313b27e1e6a38833 100644 (file)
--- a/testsuite/tests/basic/boxedints.reference
+++ b/testsuite/tests/basic/boxedints.reference
@@ -16,9 +16,9 @@ sub
 mul
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
 div
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 mod
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 and
  1... 2... 3... 4... 5...
 or
@@ -55,9 +55,9 @@ sub
 mul
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
 div
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 mod
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 and
  1... 2... 3... 4... 5...
 or
@@ -90,9 +90,9 @@ sub
 mul
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13...
 div
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 mod
- 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11...
+ 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
 and
  1... 2... 3... 4... 5...
 or

diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml
index c23f2d8c1e76821dfce2234766259328ae3e0b6e..ffbaa041cb000163ea29d493c8924296aebbe068 100644 (file)
--- a/testsuite/tests/basic/maps.ml
+++ b/testsuite/tests/basic/maps.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/basic/sets.ml b/testsuite/tests/basic/sets.ml
index 983145ee482bbfe8d5a48baa1a01e962e39488ff..f2fa158c38c683849f2c8b2e14d147180a07b759 100644 (file)
--- a/testsuite/tests/basic/sets.ml
+++ b/testsuite/tests/basic/sets.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile
index 0cec7e63f4d0a746be419b7e190469c05a8244ed..a89056685a5b77ee4280529f131495d628e004a8 100644 (file)
--- a/testsuite/tests/callback/Makefile
+++ b/testsuite/tests/callback/Makefile
@@ -1,3 +1,5 @@
+BASEDIR=../..
+
 CC=$(NATIVECC) -I $(TOPDIR)/byterun
 
 default: run-byte run-opt
@@ -10,18 +12,22 @@ run-byte: common
        @$(OCAMLC) -c tcallback.ml
        @$(OCAMLC) -o ./program -custom unix.cma callbackprim.$(O) tcallback.cmo
        @./program > bytecode.result
-       @diff -q reference bytecode.result || (echo " => failed" && exit 1) 
+       @$(DIFF) reference bytecode.result || (echo " => failed" && exit 1) 
        @echo " => passed"
 
 run-opt: common
-       @printf " ... testing 'native':"
-       @$(OCAMLOPT) -c tcallback.ml
-       @$(OCAMLOPT) -o ./program unix.cmxa callbackprim.$(O) tcallback.cmx
-       @./program > native.result
-       @diff -q reference native.result || (echo " => failed" && exit 1) 
-       @echo " => passed"
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         printf " ... testing 'native':"; \
+         $(OCAMLOPT) -c tcallback.ml; \
+         $(OCAMLOPT) -o ./program unix.cmxa callbackprim.$(O) tcallback.cmx; \
+         ./program > native.result; \
+         $(DIFF) reference native.result || (echo " => failed" && exit 1); \
+         echo " => passed"; \
+       fi
+       
+promote: defaultpromote
 
 clean: defaultclean
        @rm -f *.result ./program
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/embedded/.svnignore b/testsuite/tests/embedded/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/embedded/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/embedded/Makefile b/testsuite/tests/embedded/Makefile
index 33b9544221c96c17e403512abb21de122081cff9..ed3314346114740b9a2c202e17d84c31129ef67f 100644 (file)
--- a/testsuite/tests/embedded/Makefile
+++ b/testsuite/tests/embedded/Makefile
@@ -1,3 +1,5 @@
+BASEDIR=../..
+
 default: compile run
 
 compile:
@@ -9,10 +11,12 @@ compile:
 run:
        @printf " ... testing 'cmmain':"
        @./program > program.result
-       @diff -q program.reference program.result > /dev/null || (echo " => failed" && exit 1)
+       @$(DIFF) program.reference program.result > /dev/null || (echo " => failed" && exit 1)
        @echo " => passed"
+       
+promote: defaultpromote
 
 clean: defaultclean
        @rm -f *.result ./program
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml
index 4ebed1e7df76c0e47e62f62969bf0b6f625a1ab5..65c7a610e886347832d5b26119ba8ac5b1ae9b20 100644 (file)
--- a/testsuite/tests/embedded/cmcaml.ml
+++ b/testsuite/tests/embedded/cmcaml.ml
@@ -1,4 +1,4 @@
-(* Caml part of the code *)
+(* OCaml part of the code *)
 
 let rec fib n =
   if n < 2 then 1 else fib(n-1) + fib(n-2)

diff --git a/testsuite/tests/embedded/cmmain.c b/testsuite/tests/embedded/cmmain.c
index 87647ac50dbffcb9214e4826a9957f7ddaaed063..6c27fe1e9d0c2a066199ff2707e2f9e0677c0f41 100644 (file)
--- a/testsuite/tests/embedded/cmmain.c
+++ b/testsuite/tests/embedded/cmmain.c
@@ -9,7 +9,7 @@ extern char * format_result(int n);
 
 int main(int argc, char ** argv)
 {
-  printf("Initializing Caml code...\n");
+  printf("Initializing OCaml code...\n");
 #ifdef NO_BYTECODE_FILE
   caml_startup(argv);
 #else

diff --git a/testsuite/tests/embedded/program.reference b/testsuite/tests/embedded/program.reference
index e2752b724f54a60720b17df7f57bf1fa1da0abc3..4f27810ca9e8c270301a509ec34de92addfd6162 100644 (file)
--- a/testsuite/tests/embedded/program.reference
+++ b/testsuite/tests/embedded/program.reference
@@ -1,4 +1,4 @@
-Initializing Caml code...
+Initializing OCaml code...
 Back in C code...
 Computing fib(20)...
 Result = 10946

diff --git a/testsuite/tests/gc-roots/.svnignore b/testsuite/tests/gc-roots/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/gc-roots/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/gc-roots/Makefile b/testsuite/tests/gc-roots/Makefile
index f07d6751bacb4989c440a3acd2653036abd912db..acaf918fa978640484651eba468c4af0b2d7c3c3 100644 (file)
--- a/testsuite/tests/gc-roots/Makefile
+++ b/testsuite/tests/gc-roots/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=globroots
 C_FILES=globrootsprim
 ADD_COMPFLAGS=-w a
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/letrec/Makefile b/testsuite/tests/letrec/Makefile
new file mode 100644 (file)
index 0000000..bcc2fdb
--- /dev/null
+++ b/testsuite/tests/letrec/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/letrec/backreferences.ml b/testsuite/tests/letrec/backreferences.ml
new file mode 100644 (file)
index 0000000..4a89322
--- /dev/null
+++ b/testsuite/tests/letrec/backreferences.ml
@@ -0,0 +1,18 @@
+(* testing backreferences; some compilation scheme may handle
+   differently recursive references to a mutually-recursive RHS
+   depending on whether it is before or after in the bindings list *)
+type t = { x : t; y : t; z : t }
+
+let test =
+  let rec x = { x; y; z }
+      and y = { x; y; z }
+      and z = { x; y; z }
+  in
+  List.iter (fun (f, t_ref) ->
+    List.iter (fun t -> assert (f t == t_ref)) [x; y; z]
+  )
+    [
+      (fun t -> t.x), x;
+      (fun t -> t.y), y;
+      (fun t -> t.z), z;
+    ]

diff --git a/testsuite/tests/letrec/backreferences.reference b/testsuite/tests/letrec/backreferences.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/class_1.ml b/testsuite/tests/letrec/class_1.ml
new file mode 100644 (file)
index 0000000..a7d0338
--- /dev/null
+++ b/testsuite/tests/letrec/class_1.ml
@@ -0,0 +1,5 @@
+(* class expression are compiled to recursive bindings *)
+class test =
+object
+  method x = 1
+end

diff --git a/testsuite/tests/letrec/class_1.reference b/testsuite/tests/letrec/class_1.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/class_2.ml b/testsuite/tests/letrec/class_2.ml
new file mode 100644 (file)
index 0000000..71c7880
--- /dev/null
+++ b/testsuite/tests/letrec/class_2.ml
@@ -0,0 +1,8 @@
+(* class expressions may also contain local recursive bindings *)
+class test =
+  let rec f = print_endline "f"; fun x -> g x
+      and g = print_endline "g"; fun x -> f x in
+object
+  method f : 'a 'b. 'a -> 'b = f
+  method g : 'a 'b. 'a -> 'b = g
+end

diff --git a/testsuite/tests/letrec/class_2.reference b/testsuite/tests/letrec/class_2.reference
new file mode 100644 (file)
index 0000000..ab71375
--- /dev/null
+++ b/testsuite/tests/letrec/class_2.reference
@@ -0,0 +1,2 @@
+f
+g

diff --git a/testsuite/tests/letrec/evaluation_order_1.ml b/testsuite/tests/letrec/evaluation_order_1.ml
new file mode 100644 (file)
index 0000000..5b88844
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_1.ml
@@ -0,0 +1,20 @@
+(* test evaluation order
+
+   'y' is translated into a constant, and is therefore considered
+   non-recursive. With the current letrec compilation method,
+   it should be evaluated before x and z.
+*)
+type tree = Tree of tree list
+
+let test =
+  let rec x = (print_endline "x"; Tree [y; z])
+  and y = (print_endline "y"; Tree [])
+  and z = (print_endline "z"; Tree [x])
+  in
+  match (x, y, z) with
+    | (Tree [y1; z1], Tree[], Tree[x1]) ->
+      assert (y1 == y);
+      assert (z1 == z);
+      assert (x1 == x)
+    | _ ->
+      assert false

diff --git a/testsuite/tests/letrec/evaluation_order_1.reference b/testsuite/tests/letrec/evaluation_order_1.reference
new file mode 100644 (file)
index 0000000..f471662
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_1.reference
@@ -0,0 +1,3 @@
+y
+x
+z

diff --git a/testsuite/tests/letrec/evaluation_order_2.ml b/testsuite/tests/letrec/evaluation_order_2.ml
new file mode 100644 (file)
index 0000000..736f82a
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_2.ml
@@ -0,0 +1,18 @@
+(* A variant of evaluation_order_1.ml where the side-effects
+   are inside the blocks. Note that this changes the evaluation
+   order, as y is considered recursive.
+*)
+type tree = Tree of tree list
+
+let test =
+  let rec x = (Tree [(print_endline "x"; y); z])
+  and y = Tree (print_endline "y"; [])
+  and z = Tree (print_endline "z"; [x])
+  in
+  match (x, y, z) with
+    | (Tree [y1; z1], Tree[], Tree[x1]) ->
+      assert (y1 == y);
+      assert (z1 == z);
+      assert (x1 == x)
+    | _ ->
+      assert false

diff --git a/testsuite/tests/letrec/evaluation_order_2.reference b/testsuite/tests/letrec/evaluation_order_2.reference
new file mode 100644 (file)
index 0000000..04ec35a
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_2.reference
@@ -0,0 +1,3 @@
+x
+y
+z

diff --git a/testsuite/tests/letrec/evaluation_order_3.ml b/testsuite/tests/letrec/evaluation_order_3.ml
new file mode 100644 (file)
index 0000000..8f76a8f
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_3.ml
@@ -0,0 +1,11 @@
+type t = { x : t; y : t }
+
+let p = print_endline
+
+let test =
+  let rec x = p "x"; { x = (p "x_x"; x); y = (p "x_y"; y) }
+      and y = p "y"; { x = (p "y_x"; x); y = (p "y_y"; y) }
+   in
+   assert (x.x == x); assert (x.y == y);
+   assert (y.x == x); assert (y.y == y);
+   ()

diff --git a/testsuite/tests/letrec/evaluation_order_3.reference b/testsuite/tests/letrec/evaluation_order_3.reference
new file mode 100644 (file)
index 0000000..5b8c549
--- /dev/null
+++ b/testsuite/tests/letrec/evaluation_order_3.reference
@@ -0,0 +1,6 @@
+x
+x_y
+x_x
+y
+y_y
+y_x

diff --git a/testsuite/tests/letrec/float_block_1.ml b/testsuite/tests/letrec/float_block_1.ml
new file mode 100644 (file)
index 0000000..cdfa9d2
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_1.ml
@@ -0,0 +1,10 @@
+(* a bug in cmmgen.ml provokes a change in compilation order between
+   ocamlc and ocamlopt in certain letrec-bindings involving float
+   arrays *)
+let test =
+  let rec x = print_endline "x"; [| 1; 2; 3 |]
+      and y = print_endline "y"; [| 1.; 2.; 3. |]
+  in
+  assert (x = [| 1; 2; 3 |]);
+  assert (y = [| 1.; 2.; 3. |]);
+  ()

diff --git a/testsuite/tests/letrec/float_block_1.reference b/testsuite/tests/letrec/float_block_1.reference
new file mode 100644 (file)
index 0000000..b77b4eb
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_1.reference
@@ -0,0 +1,2 @@
+x
+y

diff --git a/testsuite/tests/letrec/float_block_2.ml b/testsuite/tests/letrec/float_block_2.ml
new file mode 100644 (file)
index 0000000..968cba4
--- /dev/null
+++ b/testsuite/tests/letrec/float_block_2.ml
@@ -0,0 +1,7 @@
+(* a bug in cmmgen.ml provokes a segfault in certain natively compiled
+   letrec-bindings involving float arrays *)
+let test =
+  let rec x = [| y; y |] and y = 1. in
+  assert (x = [| 1.; 1. |]);
+  assert (y = 1.);
+  ()

diff --git a/testsuite/tests/letrec/float_block_2.reference b/testsuite/tests/letrec/float_block_2.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/lists.ml b/testsuite/tests/letrec/lists.ml
new file mode 100644 (file)
index 0000000..5686e49
--- /dev/null
+++ b/testsuite/tests/letrec/lists.ml
@@ -0,0 +1,8 @@
+(* a test with lists, because cyclic lists are fun *)
+let test =
+  let rec li = 0::1::2::3::4::5::6::7::8::9::li in
+  match li with
+    | 0::1::2::3::4::5::6::7::8::9::
+        0::1::2::3::4::5::6::7::8::9::li' ->
+      assert (li == li')
+    | _ -> assert false

diff --git a/testsuite/tests/letrec/lists.reference b/testsuite/tests/letrec/lists.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/mixing_value_closures_1.ml b/testsuite/tests/letrec/mixing_value_closures_1.ml
new file mode 100644 (file)
index 0000000..e79f79e
--- /dev/null
+++ b/testsuite/tests/letrec/mixing_value_closures_1.ml
@@ -0,0 +1,8 @@
+(* mixing values and closures may exercise interesting code paths *)
+type t = A of (int -> int)
+let test =
+  let rec x = A f
+  and f = function
+    | 0 -> 2
+    | n -> match x with A g -> g 0
+  in assert (f 1 = 2)

diff --git a/testsuite/tests/letrec/mixing_value_closures_1.reference b/testsuite/tests/letrec/mixing_value_closures_1.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/mixing_value_closures_2.ml b/testsuite/tests/letrec/mixing_value_closures_2.ml
new file mode 100644 (file)
index 0000000..eb5fcb7
--- /dev/null
+++ b/testsuite/tests/letrec/mixing_value_closures_2.ml
@@ -0,0 +1,8 @@
+(* a polymorphic variant of test3.ml; found a real bug once *)
+let test =
+  let rec x = `A f
+  and f = function
+    | 0 -> 2
+    | n -> match x with `A g -> g 0
+  in
+  assert (f 1 = 2)

diff --git a/testsuite/tests/letrec/mixing_value_closures_2.reference b/testsuite/tests/letrec/mixing_value_closures_2.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/letrec/mutual_functions.ml b/testsuite/tests/letrec/mutual_functions.ml
new file mode 100644 (file)
index 0000000..a5b6c51
--- /dev/null
+++ b/testsuite/tests/letrec/mutual_functions.ml
@@ -0,0 +1,11 @@
+(* a simple test with mutually recursive functions *)
+let test =
+  let rec even = function
+    | 0 -> true
+    | n -> odd (n - 1)
+  and odd = function
+    | 0 -> false
+    | n -> even (n - 1)
+  in
+  List.iter (fun i -> assert (even i <> odd i && even i = (i mod 2 = 0)))
+    [0;1;2;3;4;5;6]

diff --git a/testsuite/tests/letrec/mutual_functions.reference b/testsuite/tests/letrec/mutual_functions.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/lib-bigarray-2/Makefile b/testsuite/tests/lib-bigarray-2/Makefile
index 74b02913b27126ef1213b044e5071ad23f583220..678c8c88fb6c336e326f8e3d900587c79ecb779a 100644 (file)
--- a/testsuite/tests/lib-bigarray-2/Makefile
+++ b/testsuite/tests/lib-bigarray-2/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 LIBRARIES=unix bigarray
 C_FILES=bigarrfstub
 F_FILES=bigarrf
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-bigarray/Makefile b/testsuite/tests/lib-bigarray/Makefile
index bb5076e756524e46db22073e427775569ddd74bb..5bfaa030eb3e6b8c31b4672aa3456cc57ea19960 100644 (file)
--- a/testsuite/tests/lib-bigarray/Makefile
+++ b/testsuite/tests/lib-bigarray/Makefile
@@ -1,4 +1,5 @@
+BASEDIR=../..
 LIBRARIES=unix bigarray
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml
index 85901400eb56162a478baad4d0da80d29b740578..28ed9af6f495f7d377b299a7448fbe7322ff31a2 100644 (file)
--- a/testsuite/tests/lib-bigarray/bigarrays.ml
+++ b/testsuite/tests/lib-bigarray/bigarrays.ml
@@ -384,6 +384,12 @@ let _ =
   test 12 true (test_blit_fill complex64 [Complex.zero; Complex.one; Complex.i]
                              Complex.i 1 1);
 
+  testing_function "release";
+  let a = from_list int [1;2;3;4;5] in
+  test 1 (Array1.dim a) 5;
+  Array1.release a;
+  test 2 (Array1.dim a) 0;
+  
 (* Bi-dimensional arrays *)
 
   print_newline();
@@ -533,6 +539,14 @@ let _ =
   test 7 (Array2.slice_right a 2) (from_list_fortran int [1002;2002;3002;4002;5002]);
   test 8 (Array2.slice_right a 3) (from_list_fortran int [1003;2003;3003;4003;5003]);
 
+  testing_function "release";
+  let a = (make_array2 int c_layout 0 4 6 id) in
+  test 1 (Array2.dim1 a) 4;
+  test 2 (Array2.dim2 a) 6;
+  Array2.release a;
+  test 3 (Array2.dim1 a) 0;
+  test 4 (Array2.dim2 a) 0;
+
 (* Tri-dimensional arrays *)
 
   print_newline();
@@ -654,6 +668,16 @@ let _ =
   test 6 (Array3.slice_right_1 a 1 2) (from_list_fortran int [112;212;312]);
   test 7 (Array3.slice_right_1 a 3 1) (from_list_fortran int [131;231;331]);
 
+  testing_function "release";
+  let a = (make_array3 int c_layout 0 4 5 6 id) in
+  test 1 (Array3.dim1 a) 4;
+  test 2 (Array3.dim2 a) 5;
+  test 3 (Array3.dim3 a) 6;
+  Array3.release a;
+  test 4 (Array3.dim1 a) 0;
+  test 5 (Array3.dim2 a) 0;
+  test 6 (Array3.dim3 a) 0;
+
 (* Reshaping *)
   print_newline();
   testing_function "------ Reshaping --------";
@@ -717,6 +741,7 @@ let _ =
     let a = Array1.map_file fd float64 c_layout true 10000 in
     Unix.close fd;
     for i = 0 to 9999 do a.{i} <- float i done;
+    Array1.release a;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let b = Array2.map_file fd float64 fortran_layout false 100 (-1) in
     Unix.close fd;
@@ -727,7 +752,8 @@ let _ =
       done
     done;
     test 1 !ok true;
-    b.{50,50} <- (-1.0);
+    b.{50,50} <- (-1.0);         (* private mapping -> no effect on file *)
+    Array2.release b;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd float64 c_layout false (-1) 100 in
     Unix.close fd;
@@ -738,6 +764,7 @@ let _ =
       done
     done;
     test 2 !ok true;
+    Array2.release c;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd ~pos:800L float64 c_layout false (-1) 100 in
     Unix.close fd;
@@ -748,6 +775,7 @@ let _ =
       done
     done;
     test 3 !ok true;
+    Array2.release c;
     let fd = Unix.openfile mapped_file [Unix.O_RDONLY] 0 in
     let c = Array2.map_file fd ~pos:79200L float64 c_layout false (-1) 100 in
     Unix.close fd;
@@ -755,12 +783,13 @@ let _ =
     for j = 0 to 99 do
       if c.{0,j} <> float (100 * 99 + j) then ok := false
     done;
-    test 4 !ok true
+    test 4 !ok true;
+    Array2.release c;
+    test 5 (Array2.dim1 c) 0;        
+    test 5 (Array2.dim2 c) 0
   end;
-  (* Force garbage collection of the mapped bigarrays above, otherwise
-     Win32 doesn't let us erase the file.  Notice the begin...end above
-     so that the VM doesn't keep stack references to the mapped bigarrays. *)
-  Gc.full_major();
+  (* Win32 doesn't let us erase the file if any mapping on the file is
+     still active.  Normally, they have all been released explicitly. *)
   Sys.remove mapped_file;
 
   ()

diff --git a/testsuite/tests/lib-bigarray/bigarrays.reference b/testsuite/tests/lib-bigarray/bigarrays.reference
index bdc7beae23f589f8b61ed1dfc0b975af600cdcda..def96fe4c50bdd15cdcbe77f885da386957a7c2d 100644 (file)
--- a/testsuite/tests/lib-bigarray/bigarrays.reference
+++ b/testsuite/tests/lib-bigarray/bigarrays.reference
@@ -17,6 +17,8 @@ sub
  1... 2... 3... 4... 5... 6... 7... 8... 9...
 blit, fill
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12...
+release
+ 1... 2...
 
 ------ Array2 --------
 
@@ -32,6 +34,8 @@ sub
  1... 2...
 slice
  1... 2... 3... 4... 5... 6... 7... 8...
+release
+ 1... 2... 3... 4...
 
 ------ Array3 --------
 
@@ -45,6 +49,8 @@ dim
  1... 2... 3... 4... 5... 6...
 slice1
  1... 2... 3... 4... 5... 6... 7...
+release
+ 1... 2... 3... 4... 5... 6...
 
 ------ Reshaping --------
 
@@ -58,4 +64,4 @@ reshape_2
 output_value/input_value
  1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... 14...
 map_file
- 1... 2... 3... 4...
+ 1... 2... 3... 4... 5... 5...

diff --git a/testsuite/tests/lib-bigarray/fftba.ml b/testsuite/tests/lib-bigarray/fftba.ml
index 17465df5c66549052091b95558abf5450b816449..10c22f1db44710e081bfd3238e0a035f9792668d 100644 (file)
--- a/testsuite/tests/lib-bigarray/fftba.ml
+++ b/testsuite/tests/lib-bigarray/fftba.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/lib-digest/.svnignore b/testsuite/tests/lib-digest/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/lib-digest/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/lib-digest/Makefile b/testsuite/tests/lib-digest/Makefile
index e81a715ad151e5fdebe737391925f0f3882575a2..0e64db8f137c8250e86d710030d23dd9411228d8 100644 (file)
--- a/testsuite/tests/lib-digest/Makefile
+++ b/testsuite/tests/lib-digest/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=md5
 ADD_COMPFLAGS=-w a
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml
index 6d4e6e0641ccb916680eac24c3f3bd333de8d3c3..27aebf2a3810aa95d1476343811af0c825fbb0d3 100644 (file)
--- a/testsuite/tests/lib-digest/md5.ml
+++ b/testsuite/tests/lib-digest/md5.ml
@@ -211,7 +211,7 @@ let _ =
   if (Array.length Sys.argv) > 1 && (Sys.argv.(1) = "-benchmark") then begin
     let s = String.make 50000 'a' in
     let num_iter = 1000 in
-    time "Caml implementation" num_iter
+    time "OCaml implementation" num_iter
       (fun () ->
         let ctx = init() in
         update ctx s 0 (String.length s);

diff --git a/testsuite/tests/lib-dynlink-bytecode/.ignore b/testsuite/tests/lib-dynlink-bytecode/.ignore
new file mode 100644 (file)
index 0000000..098ab51
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/.ignore
@@ -0,0 +1,4 @@
+main
+static
+custom
+marshal.data

diff --git a/testsuite/tests/lib-dynlink-bytecode/.svnignore b/testsuite/tests/lib-dynlink-bytecode/.svnignore
deleted file mode 100644 (file)
index bb92943..0000000
--- a/testsuite/tests/lib-dynlink-bytecode/.svnignore
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-main
-static
-custom
-*.a
-*.so
-
-EOF

diff --git a/testsuite/tests/lib-dynlink-bytecode/Makefile b/testsuite/tests/lib-dynlink-bytecode/Makefile
index 00ffc63ad30e849807de4c1f08343ba7b94b2f53..53e9f4692f35dc6f19c802c5d09ef743621a7261 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/Makefile
+++ b/testsuite/tests/lib-dynlink-bytecode/Makefile
@@ -1,6 +1,9 @@
+BASEDIR=../..
+
 default: compile run
 
 compile:
+       @$(OCAMLC) -c registry.ml
        @for file in stub*.c; do \
          $(OCAMLC) -c $$file; \
          $(OCAMLMKLIB) -o `echo $$file | sed -e 's/stub/plug/' | sed -e 's/\.c//'` `basename $$file c`o; \
@@ -10,27 +13,29 @@ compile:
          $(OCAMLMKLIB) -o `basename $$file .ml` `basename $$file ml`cmo; \
        done
        @$(OCAMLC) -c main.ml
-       @$(OCAMLC) -o main dynlink.cma main.cmo
-       @$(OCAMLC) -o static -linkall plug1.cma plug2.cma -use-runtime $(PREFIX)/bin/ocamlrun
-       @$(OCAMLC) -o custom -custom -linkall plug2.cma plug1.cma -I .
+       @$(OCAMLC) -o main dynlink.cma registry.cmo main.cmo
+       @$(OCAMLC) -o static -linkall registry.cmo plug1.cma plug2.cma -use-runtime $(PREFIX)/bin/ocamlrun
+       @$(OCAMLC) -o custom -custom -linkall registry.cmo plug2.cma plug1.cma -I .
 
 run:
        @printf " ... testing 'main'"
        @export LD_LIBRARY_PATH=`pwd` && ./main plug1.cma plug2.cma > main.result
-       @diff -q main.reference main.result > /dev/null || (echo " => failed" && exit 1)
+       @$(DIFF) main.reference main.result > /dev/null || (echo " => failed" && exit 1)
        @echo " => passed"
 
        @printf " ... testing 'static'"
        @export LD_LIBRARY_PATH=`pwd` && ./static > static.result
-       @diff -q static.reference static.result > /dev/null || (echo " => failed" && exit 1)
+       @$(DIFF) static.reference static.result > /dev/null || (echo " => failed" && exit 1)
        @echo " => passed"
 
        @printf " ... testing 'custom'"
        @export LD_LIBRARY_PATH=`pwd` && ./custom > custom.result
-       @diff -q custom.reference custom.result > /dev/null || (echo " => failed" && exit 1)
+       @$(DIFF) custom.reference custom.result > /dev/null || (echo " => failed" && exit 1)
        @echo " => passed"
+       
+promote: defaultpromote
 
 clean: defaultclean
-       @rm -f ./main ./static ./custom *.result
+       @rm -f ./main ./static ./custom *.result marshal.data
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-dynlink-bytecode/custom.reference b/testsuite/tests/lib-dynlink-bytecode/custom.reference
index f7eeb3aeb31f20a36c20d7fc3e7bb58c2a51a772..c9d2b57582939149f600564f99b69bec17b6cfad 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/custom.reference
+++ b/testsuite/tests/lib-dynlink-bytecode/custom.reference
@@ -1,5 +1,5 @@
-ABCDEF
 This is stub2, calling stub1:
 This is stub1!
 Ok!
 This is stub1!
+ABCDEF

diff --git a/testsuite/tests/lib-dynlink-bytecode/main.ml b/testsuite/tests/lib-dynlink-bytecode/main.ml
index bd980f10221764530fed8727e13ad602257a5760..b79504287d449a2f66244dc6439eaaf0f9b5ad08 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/main.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/main.ml
@@ -1,3 +1,8 @@
+let f x = print_string "This is Main.f\n"; x
+
+let () = Registry.register f
+
+let _ =
   Dynlink.init ();
   Dynlink.allow_unsafe_modules true;
   for i = 1 to Array.length Sys.argv - 1 do
@@ -14,4 +19,19 @@
            (Dynlink.error_message err)
       | exn ->
          Printf.printf "Error: %s\n" (Printexc.to_string exn)
-  done
+  done;
+  flush stdout;
+  try
+    let oc = open_out_bin "marshal.data" in
+    Marshal.to_channel oc (Registry.get_functions()) [Marshal.Closures];
+    close_out oc;
+    let ic = open_in_bin "marshal.data" in
+    let l = (Marshal.from_channel ic : (int -> int) list) in
+    close_in ic;
+    List.iter
+      (fun f ->
+        let res = f 0 in
+        Printf.printf "Result is: %d\n" res)
+      l
+  with Failure s ->
+    Printf.printf "Failure: %s\n" s

diff --git a/testsuite/tests/lib-dynlink-bytecode/main.reference b/testsuite/tests/lib-dynlink-bytecode/main.reference
index df46049bf314e241da525686988deae7e38a831c..577292f9aaf3ba3b2290f044fe7a14c05edd8562 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/main.reference
+++ b/testsuite/tests/lib-dynlink-bytecode/main.reference
@@ -1,7 +1,13 @@
 Loading plug1.cma
+This is stub1!
 ABCDEF
 Loading plug2.cma
-This is stub1!
 This is stub2, calling stub1:
 This is stub1!
 Ok!
+This is Plug2.f
+Result is: 2
+This is Plug1.f
+Result is: 1
+This is Main.f
+Result is: 0

diff --git a/testsuite/tests/lib-dynlink-bytecode/plug1.ml b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
index 3246045170298eee41687e86ee1ead9a5f2bfdd4..d0490689fbe116e2732a2571182ea5a95c795ed3 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/plug1.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug1.ml
@@ -1,4 +1,7 @@
 external stub1: unit -> string = "stub1"
 
+let f x = print_string "This is Plug1.f\n"; x + 1
+
+let () = Registry.register f
 
 let () = print_endline (stub1 ())

diff --git a/testsuite/tests/lib-dynlink-bytecode/plug2.ml b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
index 05f4fdaeda02d5e4bc1447cf57f909edb982fd21..350374e5b8b83c6a6bdf420ba90aca52831c9ba2 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/plug2.ml
+++ b/testsuite/tests/lib-dynlink-bytecode/plug2.ml
@@ -1,4 +1,7 @@
 external stub2: unit -> unit = "stub2"
 
+let f x = print_string "This is Plug2.f\n"; x + 2
+
+let () = Registry.register f
 
 let () = stub2 ()

diff --git a/testsuite/tests/lib-dynlink-bytecode/registry.ml b/testsuite/tests/lib-dynlink-bytecode/registry.ml
new file mode 100644 (file)
index 0000000..e0f7642
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-bytecode/registry.ml
@@ -0,0 +1,7 @@
+let functions = ref ([]: (int -> int) list)
+
+let register f =
+  functions := f :: !functions
+
+let get_functions () =
+  !functions

diff --git a/testsuite/tests/lib-dynlink-bytecode/static.reference b/testsuite/tests/lib-dynlink-bytecode/static.reference
index 32281bcf45041c403b82dadcb48cd3b839a7bd31..4faa129c34cffe737c7689539ed77d03ed42fe63 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/static.reference
+++ b/testsuite/tests/lib-dynlink-bytecode/static.reference
@@ -1,5 +1,5 @@
-ABCDEF
 This is stub1!
+ABCDEF
 This is stub2, calling stub1:
 This is stub1!
 Ok!

diff --git a/testsuite/tests/lib-dynlink-bytecode/stub1.c b/testsuite/tests/lib-dynlink-bytecode/stub1.c
index 18ddf3f13658c22f407f050fca9188e9b19c6614..dcae562a415f17cdd738a9d33103834b4ad46348 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/stub1.c
+++ b/testsuite/tests/lib-dynlink-bytecode/stub1.c
@@ -5,7 +5,7 @@
 
 value stub1() {
   CAMLlocal1(x);
-  printf("This is stub1!\n");
+  printf("This is stub1!\n"); fflush(stdout);
   x = caml_copy_string("ABCDEF");
   return x;
 }

diff --git a/testsuite/tests/lib-dynlink-bytecode/stub2.c b/testsuite/tests/lib-dynlink-bytecode/stub2.c
index a118673543361a1a3d9e04401c6fa51b91fb5651..4c6e6e3c212941e05fe0db46f4c7a5de216b8e14 100644 (file)
--- a/testsuite/tests/lib-dynlink-bytecode/stub2.c
+++ b/testsuite/tests/lib-dynlink-bytecode/stub2.c
@@ -6,8 +6,8 @@
 extern value stub1();
 
 value stub2() {
-  printf("This is stub2, calling stub1:\n");
+  printf("This is stub2, calling stub1:\n"); fflush(stdout);
   stub1();
-  printf("Ok!\n");
+  printf("Ok!\n"); fflush(stdout);
   return Val_unit;
 }

diff --git a/testsuite/tests/lib-dynlink-csharp/Makefile b/testsuite/tests/lib-dynlink-csharp/Makefile
index 774eaacac7309bf4a2ff27d93322ab98e0e8ee2a..c65b044e8edf4d3f870bd2f4b36f619682357782 100644 (file)
--- a/testsuite/tests/lib-dynlink-csharp/Makefile
+++ b/testsuite/tests/lib-dynlink-csharp/Makefile
@@ -1,6 +1,12 @@
+BASEDIR=../..
 CSC=csc
 
-default: prepare bytecode bytecode-dll native native-dll
+default:
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         $(MAKE) all; \
+       fi
+
+all: prepare bytecode bytecode-dll native native-dll
 
 prepare:
        @$(OCAMLC) -c plugin.ml
@@ -14,7 +20,7 @@ bytecode:
          $(OCAMLC) -output-obj -o main.dll dynlink.cma main.ml entry.c; \
          $(CSC) /out:main.exe main.cs; \
          ./main.exe > bytecode.result; \
-         diff -q bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
+         $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
        fi
 
 bytecode-dll:
@@ -26,7 +32,7 @@ bytecode-dll:
          $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../byterun/libcamlrun.$(A)  $(BYTECCLIBS) -v; \
          $(CSC) /out:main.exe main.cs; \
          ./main.exe > bytecode.result; \
-         diff -q bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
+         $(DIFF) bytecode.reference bytecode.result > /dev/null && echo " => passed" || echo " => failed"; \
        fi
 
 native:
@@ -37,7 +43,7 @@ native:
          $(OCAMLOPT) -output-obj -o main.dll dynlink.cmxa entry.c main.ml; \
          $(CSC) /out:main.exe main.cs; \
          ./main.exe > native.result; \
-         diff -q native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
+         $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
        fi
 
 native-dll:
@@ -49,10 +55,12 @@ native-dll:
          $(MKDLL) -maindll -o main.dll main_obj.$(O) entry.$(O) ../../asmrun/libasmrun.lib -v; \
          $(CSC) /out:main.exe main.cs; \
          ./main.exe > native.result; \
-         diff -q native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
+         $(DIFF) native.reference native.result > /dev/null && echo " => passed" || echo " => failed"; \
        fi
 
+promote: defaultpromote
+
 clean: defaultclean
        @rm -f *.result *.exe *.dll
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-dynlink-csharp/bytecode.reference b/testsuite/tests/lib-dynlink-csharp/bytecode.reference
index 65592193a1bc7c14522c334d59739b37ea7f0a8c..a76daa2309b0d1362c63796fb3498597e057dc23 100644 (file)
--- a/testsuite/tests/lib-dynlink-csharp/bytecode.reference
+++ b/testsuite/tests/lib-dynlink-csharp/bytecode.reference
@@ -1,4 +1,4 @@
-Now starting the Caml engine.
+Now starting the OCaml engine.
 Main is running.
 Loading ../../../otherlibs/bigarray/bigarray.cma
 I'm the plugin.

diff --git a/testsuite/tests/lib-dynlink-csharp/main.cs b/testsuite/tests/lib-dynlink-csharp/main.cs
index a03bfd60ab9a689583b197d8ec75b4a4691e32d2..5cbb8e86891e0d3a49e8395332ce29dd41e7e811 100755 (executable)
--- a/testsuite/tests/lib-dynlink-csharp/main.cs
+++ b/testsuite/tests/lib-dynlink-csharp/main.cs
@@ -5,7 +5,7 @@ public class M {
   public static extern void start_caml_engine();
 
   public static void Main() {
-    System.Console.WriteLine("Now starting the Caml engine.");
+    System.Console.WriteLine("Now starting the OCaml engine.");
     start_caml_engine();
   }
 }

diff --git a/testsuite/tests/lib-dynlink-csharp/native.reference b/testsuite/tests/lib-dynlink-csharp/native.reference
index b6c9e5c4304f260fc1daf59cb0fed00206e43fd7..684f979a8f7c9fd33b815796e89cbfbe20a47ab9 100644 (file)
--- a/testsuite/tests/lib-dynlink-csharp/native.reference
+++ b/testsuite/tests/lib-dynlink-csharp/native.reference
@@ -1,4 +1,4 @@
-Now starting the Caml engine.
+Now starting the OCaml engine.
 Main is running.
 Loading ../../../otherlibs/bigarray/bigarray.cmxs
 I'm the plugin.

diff --git a/testsuite/tests/lib-dynlink-native/.ignore b/testsuite/tests/lib-dynlink-native/.ignore
new file mode 100644 (file)
index 0000000..601ed1f
--- /dev/null
+++ b/testsuite/tests/lib-dynlink-native/.ignore
@@ -0,0 +1,4 @@
+mypack.pack.s
+result
+main
+marshal.data

diff --git a/testsuite/tests/lib-dynlink-native/.svnignore b/testsuite/tests/lib-dynlink-native/.svnignore
deleted file mode 100644 (file)
index 44c6a06..0000000
--- a/testsuite/tests/lib-dynlink-native/.svnignore
+++ /dev/null
@@ -1,15 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-mypack.pack.s
-result
-main
-*.so
-*.a
-
-EOF

diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile
index 49bd04a17a6e304f2c3375bb56b4c5a906e768db..9aac1dbecacf687814af9387d30f192605494771 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/Makefile
+++ b/testsuite/tests/lib-dynlink-native/Makefile
@@ -1,4 +1,12 @@
-default: compile run
+BASEDIR=../..
+
+
+default:
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         $(MAKE) all; \
+       fi
+
+all: compile run
 
 PLUGINS=plugin.so plugin2.so sub/plugin.so sub/plugin3.so plugin4.so mypack.so packed1.so packed1_client.so pack_client.so plugin_ref.so plugin_high_arity.so plugin_ext.so plugin_simple.so bug.so plugin_thread.so plugin4_unix.so a.so b.so c.so
 
@@ -8,8 +16,8 @@ compile: $(PLUGINS) main mylib.so
 
 run:
        @printf " ... testing 'main'"
-       @./main plugin_thread.so > result
-       @diff -q reference result > /dev/null || (echo " => failed" && exit 1)
+       @./main plugin.so plugin2.so plugin_thread.so > result
+       @$(DIFF) reference result > /dev/null || (echo " => failed" && exit 1)
        @echo " => passed"
 
 main: api.cmx main.cmx
@@ -62,9 +70,12 @@ mylib.cmxa: plugin.cmx plugin2.cmx
 factorial.$(O): factorial.c
        @$(OCAMLOPT) -c -ccopt "$(SHAREDCCCOMPOPTS)" factorial.c
 
+promote:
+       @cp result reference
+
 clean: defaultclean
        @rm -f result *.so *.o *.cm* main main_ext *.exe *.s *.asm *.obj
        @rm -f *.a *.lib
        @rm -f sub/*.so sub/*.o sub/*.cm* sub/*.s sub/*.asm sub/*.obj
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-dynlink-native/api.ml b/testsuite/tests/lib-dynlink-native/api.ml
index 843a1c78f7d7ada03feaaeb30eb2389ba0835336..304ee1f1f0aa80d8fef8e4a56aaf6e4752022e10 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/api.ml
+++ b/testsuite/tests/lib-dynlink-native/api.ml
@@ -14,5 +14,7 @@ let cbs = ref []
 let add_cb f = cbs := f :: !cbs
 let runall () = List.iter (fun f -> f ()) !cbs
 
+(*
 let () =
   at_exit runall
+*)

diff --git a/testsuite/tests/lib-dynlink-native/main.ml b/testsuite/tests/lib-dynlink-native/main.ml
index b21253fb2db0454881e93b53ac6d39cfffde5cbc..04b3aef7bb51717c9393bcd43a92f6d926c62ab4 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/main.ml
+++ b/testsuite/tests/lib-dynlink-native/main.ml
@@ -1,3 +1,6 @@
+let () =
+  Api.add_cb (fun () -> print_endline "Callback from main")
+
 let ()  =
   Dynlink.init ();
   Dynlink.allow_unsafe_modules true;
@@ -15,6 +18,18 @@ let ()  =
            (Dynlink.error_message err)
       | exn ->
          Printf.printf "Error: %s\n" (Printexc.to_string exn)
-  done
+  done;
+  flush stdout;
+  try
+    let oc = open_out_bin "marshal.data" in
+    Marshal.to_channel oc !Api.cbs [Marshal.Closures];
+    close_out oc;
+    let ic = open_in_bin "marshal.data" in
+    let l = (Marshal.from_channel ic : (unit -> unit) list) in
+    close_in ic;
+    List.iter (fun f -> f()) l
+  with Failure s ->
+    Printf.printf "Failure: %s\n" s
+
 
 

diff --git a/testsuite/tests/lib-dynlink-native/plugin.ml b/testsuite/tests/lib-dynlink-native/plugin.ml
index 501f1bfd3293ba85b930777b4de87bb671dcecf9..f307b4f11c934c009f37eceb9e7d313edddb3d3d 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin.ml
@@ -6,5 +6,6 @@ let facts = [ fact 1; fact 2; fact 3; fact (Random.int 4) ]
 
 let () =
   Api.reg_mod "Plugin";
+  Api.add_cb (fun () -> print_endline "Callback from plugin");
   print_endline "COUCOU"; 
   ()

diff --git a/testsuite/tests/lib-dynlink-native/plugin2.ml b/testsuite/tests/lib-dynlink-native/plugin2.ml
index daecace842ca06e7691635dbacc0f4199dac658c..109c129d1a89f65f5d43adb04e8061d0c1560374 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/plugin2.ml
+++ b/testsuite/tests/lib-dynlink-native/plugin2.ml
@@ -2,7 +2,7 @@
 
 let () =
   Api.reg_mod "Plugin2";
+  Api.add_cb (fun () -> print_endline "Callback from plugin2");
 (*  let i = ex 3 in*)
   List.iter (fun i -> Printf.printf "%i\n" i) Plugin.facts;
-  Printf.printf "XXX\n";
-  raise Exit
+  Printf.printf "XXX\n"

diff --git a/testsuite/tests/lib-dynlink-native/reference b/testsuite/tests/lib-dynlink-native/reference
index c6adb139ea08f7aa56c2f70ef1a9510fdf3bb2ed..e9e4ee45dd41f5b7d2330b2f296702bc09e499bf 100644 (file)
--- a/testsuite/tests/lib-dynlink-native/reference
+++ b/testsuite/tests/lib-dynlink-native/reference
@@ -1,3 +1,13 @@
+Loading plugin.so
+Registering module Plugin
+COUCOU
+Loading plugin2.so
+Registering module Plugin2
+1
+2
+6
+1
+XXX
 Loading plugin_thread.so
 Registering module Plugin_thread
 Thread
@@ -15,3 +25,6 @@ Thread
 Thread
 Thread
 Thread
+Callback from plugin2
+Callback from plugin
+Callback from main

diff --git a/testsuite/tests/lib-hashtbl/Makefile b/testsuite/tests/lib-hashtbl/Makefile
new file mode 100644 (file)
index 0000000..4ba0bff
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml
new file mode 100644 (file)
index 0000000..5699587
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/hfun.ml
@@ -0,0 +1,50 @@
+(* Testing the hash function Hashtbl.hash *)
+(* What is tested:
+     - reproducibility on various platforms, esp. 32/64 bit issues
+     - equal values hash equally, esp NaNs. *)
+
+open Printf
+
+let _ =
+  printf "-- Strings:\n";
+  printf "\"\"\t\t%08x\n" (Hashtbl.hash "");
+  printf "\"Hello world\"\t%08x\n" (Hashtbl.hash "Hello world");
+
+  printf "-- Integers:\n";
+  printf "0\t\t%08x\n" (Hashtbl.hash 0);
+  printf "-1\t\t%08x\n" (Hashtbl.hash (-1));
+  printf "42\t\t%08x\n" (Hashtbl.hash 42);
+  printf "2^30-1\t\t%08x\n" (Hashtbl.hash 0x3FFF_FFFF);
+  printf "-2^30\t\t%08x\n" (Hashtbl.hash (-0x4000_0000));
+
+  printf "-- Floats:\n";
+  printf "+0.0\t\t%08x\n" (Hashtbl.hash 0.0);
+  printf "-0.0\t\t%08x\n" (Hashtbl.hash (-. 0.0));
+  printf "+infty\t\t%08x\n" (Hashtbl.hash infinity);
+  printf "-infty\t\t%08x\n" (Hashtbl.hash neg_infinity);
+  printf "NaN\t\t%08x\n" (Hashtbl.hash nan);
+  printf "NaN#2\t\t%08x\n" (Hashtbl.hash (Int64.float_of_bits 0xFF_F0_00_12_34_56_78_9AL));
+  printf "NaN#3\t\t%08x\n" (Hashtbl.hash (0.0 /. 0.0));
+
+  printf "-- Native integers:\n";
+  printf "0\t\t%08x\n" (Hashtbl.hash 0n);
+  printf "-1\t\t%08x\n" (Hashtbl.hash (-1n));
+  printf "42\t\t%08x\n" (Hashtbl.hash 42n);
+  printf "2^30-1\t\t%08x\n" (Hashtbl.hash 0x3FFF_FFFFn);
+  printf "-2^30\t\t%08x\n" (Hashtbl.hash (-0x4000_0000n));
+
+  printf "-- Lists:\n";
+  printf "[0..10]\t\t%08x\n" (Hashtbl.hash [0;1;2;3;4;5;6;7;8;9;10]);
+  printf "[0..12]\t\t%08x\n" (Hashtbl.hash [0;1;2;3;4;5;6;7;8;9;10;11;12]);
+  printf "[10..0]\t\t%08x\n" (Hashtbl.hash [10;9;8;7;6;5;4;3;2;1;0]);
+
+  ()
+
+
+
+
+
+
+
+
+  

diff --git a/testsuite/tests/lib-hashtbl/hfun.reference b/testsuite/tests/lib-hashtbl/hfun.reference
new file mode 100644 (file)
index 0000000..2e92cf4
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/hfun.reference
@@ -0,0 +1,27 @@
+-- Strings:
+""             00000000
+"Hello world"  364b8272
+-- Integers:
+0              07be548a
+-1             3653e015
+42             1792870b
+2^30-1         23c392d0
+-2^30          0c66fde3
+-- Floats:
++0.0           0f478b8c
+-0.0           0f478b8c
++infty         23ea56fb
+-infty         059f7872
+NaN            3228858d
+NaN#2          3228858d
+NaN#3          3228858d
+-- Native integers:
+0              3f19274a
+-1             3653e015
+42             3e33aef8
+2^30-1         3711bf46
+-2^30          2e71f39c
+-- Lists:
+[0..10]                0ade0fc9
+[0..12]                0ade0fc9
+[10..0]                0cd6259d

diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml
new file mode 100644 (file)
index 0000000..84a71be
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/htbl.ml
@@ -0,0 +1,192 @@
+(* Hashtable operations, using maps as a reference *)
+
+open Printf
+
+module Test(H: Hashtbl.S) (M: Map.S with type key = H.key) = struct
+
+  let incl_mh m h =
+    try
+      M.iter
+        (fun k d ->
+          let d' = H.find h k in if d <> d' then raise Exit)
+        m;
+      true
+    with Exit | Not_found -> false
+
+  let domain_hm h m =
+    try
+      H.iter
+        (fun k d -> if not (M.mem k m) then raise Exit)
+        h;
+      true
+    with Exit -> false
+
+  let incl_hm h m =
+    try
+      H.iter
+        (fun k d ->
+           let d' = M.find k m in if d <> d' then raise Exit)
+        h;
+      true
+    with Exit | Not_found -> false
+
+  let test data =
+    let n = Array.length data in
+    let h = H.create 51 and m = ref M.empty in
+    (* Insert all data with H.add *)
+    Array.iter
+      (fun (k, d) -> H.add h k d; m := M.add k d !m)
+      data;
+    printf "Insertion: %s\n"
+           (if incl_mh !m h && domain_hm h !m then "passed" else "FAILED");
+    (* Insert all data with H.replace *)
+    H.clear h; m := M.empty;
+    Array.iter
+      (fun (k, d) -> H.replace h k d; m := M.add k d !m)
+      data;
+    printf "Insertion: %s\n"
+           (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED");
+    (* Remove some of the data *)
+    for i = 0 to n/3 - 1 do
+      let (k, _) = data.(i) in H.remove h k; m := M.remove k !m
+    done;
+    printf "Removal: %s\n"
+           (if incl_mh !m h && incl_hm h !m then "passed" else "FAILED")
+
+end
+
+module MS = Map.Make(struct type t = string
+                            let compare (x:t) (y:t) = Pervasives.compare x y
+                     end)
+module MI = Map.Make(struct type t = int
+                            let compare (x:t) (y:t) = Pervasives.compare x y
+                     end)
+
+module MSP = Map.Make(struct type t = string*string
+                            let compare (x:t) (y:t) = Pervasives.compare x y
+                     end)
+
+module MSL = Map.Make(struct type t = string list
+                            let compare (x:t) (y:t) = Pervasives.compare x y
+                     end)
+
+(* Generic hash wrapped as a functorial hash *)
+
+module HofM (M: Map.S) : Hashtbl.S with type key = M.key =
+  struct
+    type key = M.key
+    type 'a t = (key, 'a) Hashtbl.t
+    let create s = Hashtbl.create s
+    let clear = Hashtbl.clear
+    let copy = Hashtbl.copy
+    let add = Hashtbl.add
+    let remove = Hashtbl.remove
+    let find = Hashtbl.find
+    let find_all = Hashtbl.find_all
+    let replace = Hashtbl.replace
+    let mem = Hashtbl.mem
+    let iter = Hashtbl.iter
+    let fold = Hashtbl.fold
+    let length = Hashtbl.length
+    let stats = Hashtbl.stats
+  end
+
+module HS1 = HofM(MS)
+module HI1 = HofM(MI)
+module HSP = HofM(MSP)
+module HSL = HofM(MSL)
+
+(* Specific functorial hashes *)
+
+module HS2 = Hashtbl.Make(struct type t = string
+                                 let equal (x:t) (y:t) = x=y
+                                 let hash = Hashtbl.hash end)
+
+module HI2 = Hashtbl.Make(struct type t = int
+                                 let equal (x:t) (y:t) = x=y
+                                 let hash = Hashtbl.hash end)
+(* Instantiating the test *)
+
+module TS1 = Test(HS1)(MS)
+module TS2 = Test(HS2)(MS)
+module TI1 = Test(HI1)(MI)
+module TI2 = Test(HI2)(MI)
+module TSP = Test(HSP)(MSP)
+module TSL = Test(HSL)(MSL)
+
+(* Data set: strings from a file, associated with their line number *)
+
+let file_data filename =
+  let ic = open_in filename in
+  let lineno = ref 0 in
+  let data = ref [] in
+  begin try
+    while true do
+      let l = input_line ic in
+      incr lineno;
+      data := (l, !lineno) :: !data
+    done
+  with End_of_file -> ()
+  end;
+  close_in ic;
+  Array.of_list !data
+
+(* Data set: fixed strings *)
+
+let string_data = [|
+  "Si", 0; "non", 1; "e", 2; "vero", 3; "e", 4; "ben", 5; "trovato", 6;
+  "An", 10; "apple", 11; "a", 12; "day", 13; "keeps", 14; "the", 15;
+  "doctor", 16; "away", 17;
+  "Pierre", 20; "qui", 21; "roule", 22; "n'amasse", 23; "pas", 24; "mousse", 25;
+  "Asinus", 30; "asinum", 31; "fricat", 32
+|]
+
+(* Data set: random integers *)
+
+let random_integers num range =
+  let data = Array.make num (0,0) in
+  for i = 0 to num - 1 do
+    data.(i) <- (Random.int range, i)
+  done;
+  data
+
+(* Data set: pairs *)
+
+let pair_data data =
+  Array.map (fun (k, d) -> ((k, k), d)) data
+
+(* Data set: lists *)
+
+let list_data data =
+  let d = Array.make (Array.length data / 10) ([], 0) in
+  let j = ref 0 in
+  let rec mklist n =
+    if n <= 0 || !j >= Array.length data then [] else begin
+      let hd = fst data.(!j) in
+      incr j;
+      let tl = mklist (n-1) in
+      hd :: tl
+    end in
+  for i = 0 to Array.length d - 1 do
+    d.(i) <- (mklist (Random.int 16), i)
+  done;
+  d
+
+(* The test *)
+
+let _ =
+  printf "-- Random integers, large range\n%!";
+  TI1.test (random_integers 100_000 1_000_000);
+  printf "-- Random integers, narrow range\n%!";
+  TI2.test (random_integers 100_000 1_000);
+  let d =
+    try file_data "/usr/share/dict/words" with Sys_error _ -> string_data in
+  printf "-- Strings, generic interface\n%!";
+  TS1.test d;
+  printf "-- Strings, functorial interface\n%!";
+  TS2.test d;
+  printf "-- Pairs of strings\n%!";
+  TSP.test (pair_data d);
+  printf "-- Lists of strings\n%!";
+  TSL.test (list_data d)
+ 

diff --git a/testsuite/tests/lib-hashtbl/htbl.reference b/testsuite/tests/lib-hashtbl/htbl.reference
new file mode 100644 (file)
index 0000000..08ca22f
--- /dev/null
+++ b/testsuite/tests/lib-hashtbl/htbl.reference
@@ -0,0 +1,24 @@
+-- Random integers, large range
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Random integers, narrow range
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Strings, generic interface
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Strings, functorial interface
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Pairs of strings
+Insertion: passed
+Insertion: passed
+Removal: passed
+-- Lists of strings
+Insertion: passed
+Insertion: passed
+Removal: passed

diff --git a/testsuite/tests/lib-marshal/Makefile b/testsuite/tests/lib-marshal/Makefile
index df63a1fd56eeb95b04c2eefd94b2cdaa4974f54b..1f78273d3d38d9ea8eae5b8149d689e19937ddcb 100644 (file)
--- a/testsuite/tests/lib-marshal/Makefile
+++ b/testsuite/tests/lib-marshal/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=intext
 C_FILES=intextaux
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-num-2/Makefile b/testsuite/tests/lib-num-2/Makefile
index 7b7ffec4f6a5302d72f3c9b2fd86648abd5b0b3c..7a307e41c149c9bbe1aa8d6ad7568e4881860354 100644 (file)
--- a/testsuite/tests/lib-num-2/Makefile
+++ b/testsuite/tests/lib-num-2/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 LIBRARIES=nums
 PROGRAM_ARGS=1000
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-num/Makefile b/testsuite/tests/lib-num/Makefile
index 8b7b327a094b624645346e2f92dc623ab510ae63..08ebbd97f4a5fff2b1630b5570d07c39897f2a44 100644 (file)
--- a/testsuite/tests/lib-num/Makefile
+++ b/testsuite/tests/lib-num/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 MODULES=test test_nats test_big_ints test_ratios test_nums test_io
 MAIN_MODULE=end_test
 ADD_COMPFLAGS=-w a
 LIBRARIES=nums
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-num/end_test.reference b/testsuite/tests/lib-num/end_test.reference
index 8a78296e423d77b343254da8101d3210ebddeec9..8e7ac4b6cd3fac564ff1b8b48e12af9ebe6ed76d 100644 (file)
--- a/testsuite/tests/lib-num/end_test.reference
+++ b/testsuite/tests/lib-num/end_test.reference
@@ -83,6 +83,8 @@ shift_right_towards_zero_big_int
  1... 2...
 extract_big_int
  1... 2... 3... 4... 5... 6...
+hashing of big integers
+ 1... 2... 3... 4... 5... 6...
 create_ratio
  1... 2... 3... 4... 5... 6... 7... 8...
 create_normalized_ratio

diff --git a/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml
index 46ffc597283db9973e48f4927f4fe14fde1732b7..badc52160148fd8cd96ddfc2f617a43d5181005a 100644 (file)
--- a/testsuite/tests/lib-num/test_big_ints.ml
+++ b/testsuite/tests/lib-num/test_big_ints.ml
@@ -922,3 +922,23 @@ test 5 eq_big_int
 test 6 eq_big_int
   (extract_big_int (big_int_of_int (-1)) 2048 254,
    zero_big_int);;
+
+testing_function "hashing of big integers";;
+
+test 1 eq_int (Hashtbl.hash zero_big_int,
+               955772237);;
+test 2 eq_int (Hashtbl.hash unit_big_int,
+               992063522);;
+test 3 eq_int (Hashtbl.hash (minus_big_int unit_big_int),
+               161678167);;
+test 4 eq_int (Hashtbl.hash (big_int_of_string "123456789123456789"),
+               755417385);;
+test 5 eq_int (Hashtbl.hash (sub_big_int 
+                               (big_int_of_string "123456789123456789")
+                               (big_int_of_string "123456789123456789")),
+               955772237);;
+test 6 eq_int (Hashtbl.hash (sub_big_int 
+                               (big_int_of_string "123456789123456789")
+                               (big_int_of_string "123456789123456788")),
+              992063522);;
+

diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile
new file mode 100644 (file)
index 0000000..94c4047
--- /dev/null
+++ b/testsuite/tests/lib-printf/Makefile
@@ -0,0 +1,7 @@
+#MODULES=
+MAIN_MODULE=tprintf
+ADD_COMPFLAGS=-I $(BASEDIR)/lib
+ADD_MODULES=testing
+
+include ../../makefiles/Makefile.one
+include ../../makefiles/Makefile.common

diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml
new file mode 100644 (file)
index 0000000..16046a7
--- /dev/null
+++ b/testsuite/tests/lib-printf/tprintf.ml
@@ -0,0 +1,468 @@
+(*************************************************************************)
+(*                                                                       *)
+(*                                OCaml                                  *)
+(*                                                                       *)
+(*         Damien Doligez, projet Gallium, INRIA Rocquencourt            *)
+(*                                                                       *)
+(*   Copyright 2011 Institut National de Recherche en Informatique et    *)
+(*   en Automatique.  All rights reserved.  This file is distributed     *)
+(*   under the terms of the Q Public License version 1.0.                *)
+(*                                                                       *)
+(*************************************************************************)
+
+(* $Id: tscanf.ml 10713 2010-10-08 11:53:19Z doligez $ *)
+
+(*
+
+A test file for the Printf module.
+
+*)
+
+open Testing;;
+open Printf;;
+
+try
+
+  printf "d/i positive\n%!";
+  test (sprintf "%d/%i" 42 43 = "42/43");
+  test (sprintf "%-4d/%-5i" 42 43 = "42  /43   ");
+  test (sprintf "%04d/%05i" 42 43 = "0042/00043");
+  test (sprintf "%+d/%+i" 42 43 = "+42/+43");
+  test (sprintf "% d/% i" 42 43 = " 42/ 43");
+  test (sprintf "%#d/%#i" 42 43 = "42/43");
+  test (sprintf "%4d/%5i" 42 43 = "  42/   43");
+  test (sprintf "%*d/%*i" 4 42 5 43 = "  42/   43");
+  test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43  ");
+
+  printf "\nd/i negative\n%!";
+  test (sprintf "%d/%i" (-42) (-43) = "-42/-43");
+  test (sprintf "%-4d/%-5i" (-42) (-43) = "-42 /-43  ");
+  test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043");
+  test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43");
+  test (sprintf "% d/% i" (-42) (-43) = "-42/-43");
+  test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");
+  test (sprintf "%4d/%5i" (-42) (-43) = " -42/  -43");
+  test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/  -43");
+  test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43  ");
+
+  printf "\nu positive\n%!";
+  test (sprintf "%u" 42 = "42");
+  test (sprintf "%-4u" 42 = "42  ");
+  test (sprintf "%04u" 42 = "0042");
+  test (sprintf "%+u" 42 = "42");
+  test (sprintf "% u" 42 = "42");
+  test (sprintf "%#u" 42 = "42");
+  test (sprintf "%4u" 42 = "  42");
+  test (sprintf "%*u" 4 42 = "  42");
+  test (sprintf "%-0+ #6d" 42 = "+42   ");
+
+  printf "\nu negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%u" (-1) = "2147483647");
+  | 64 ->
+     test (sprintf "%u" (-1) = "9223372036854775807");
+  | _ -> test false
+  end;
+
+  printf "\nx positive\n%!";
+  test (sprintf "%x" 42 = "2a");
+  test (sprintf "%-4x" 42 = "2a  ");
+  test (sprintf "%04x" 42 = "002a");
+  test (sprintf "%+x" 42 = "2a");
+  test (sprintf "% x" 42 = "2a");
+  test (sprintf "%#x" 42 = "0x2a");
+  test (sprintf "%4x" 42 = "  2a");
+  test (sprintf "%*x" 5 42 = "   2a");
+  test (sprintf "%-0+ #*x" 5 42 = "0x2a ");
+
+  printf "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%x" (-42) = "7fffffd6");
+  | 64 ->
+     test (sprintf "%x" (-42) = "7fffffffffffffd6");
+  | _ -> test false
+  end;
+
+  printf "\nX positive\n%!";
+  test (sprintf "%X" 42 = "2A");
+  test (sprintf "%-4X" 42 = "2A  ");
+  test (sprintf "%04X" 42 = "002A");
+  test (sprintf "%+X" 42 = "2A");
+  test (sprintf "% X" 42 = "2A");
+  test (sprintf "%#X" 42 = "0X2A");
+  test (sprintf "%4X" 42 = "  2A");
+  test (sprintf "%*X" 5 42 = "   2A");
+  test (sprintf "%-0+ #*X" 5 42 = "0X2A ");
+
+  printf "\nx negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%X" (-42) = "7FFFFFD6");
+  | 64 ->
+     test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6");
+  | _ -> test false
+  end;
+
+  printf "\no positive\n%!";
+  test (sprintf "%o" 42 = "52");
+  test (sprintf "%-4o" 42 = "52  ");
+  test (sprintf "%04o" 42 = "0052");
+  test (sprintf "%+o" 42 = "52");
+  test (sprintf "% o" 42 = "52");
+  test (sprintf "%#o" 42 = "052");
+  test (sprintf "%4o" 42 = "  52");
+  test (sprintf "%*o" 5 42 = "   52");
+  test (sprintf "%-0+ #*o" 5 42 = "052  ");
+
+  printf "\no negative\n%!";
+  begin match Sys.word_size with
+  | 32 ->
+     test (sprintf "%o" (-42) = "17777777726");
+  | 64 ->
+     test (sprintf "%o" (-42) = "777777777777777777726");
+  | _ -> test false
+  end;
+
+  printf "\ns\n%!";
+  test (sprintf "%s" "foo" = "foo");
+  test (sprintf "%-5s" "foo" = "foo  ");
+  test (sprintf "%05s" "foo" = "  foo");
+  test (sprintf "%+s" "foo" = "foo");
+  test (sprintf "% s" "foo" = "foo");
+  test (sprintf "%#s" "foo" = "foo");
+  test (sprintf "%5s" "foo" = "  foo");
+  test (sprintf "%1s" "foo" = "foo");
+  test (sprintf "%*s" 6 "foo" = "   foo");
+  test (sprintf "%*s" 2 "foo" = "foo");
+  test (sprintf "%-0+ #5s" "foo" = "foo  ");
+  test (sprintf "%s@" "foo" = "foo@");
+  test (sprintf "%s@inria.fr" "foo" = "foo@inria.fr");
+  test (sprintf "%s@%s" "foo" "inria.fr" = "foo@inria.fr");
+
+  printf "\nS\n%!";
+  test (sprintf "%S" "fo\"o" = "\"fo\\\"o\"");
+(*  test (sprintf "%-5S" "foo" = "\"foo\"  ");   padding not done *)
+(*  test (sprintf "%05S" "foo" = "  \"foo\"");   padding not done *)
+  test (sprintf "%+S" "foo" = "\"foo\"");
+  test (sprintf "% S" "foo" = "\"foo\"");
+  test (sprintf "%#S" "foo" = "\"foo\"");
+(*  test (sprintf "%5S" "foo" = "  \"foo\"");    padding not done *)
+  test (sprintf "%1S" "foo" = "\"foo\"");
+(*  test (sprintf "%*S" 6 "foo" = "   \"foo\"");  padding not done *)
+  test (sprintf "%*S" 2 "foo" = "\"foo\"");
+(*  test (sprintf "%-0+ #5S" "foo" = "\"foo\"  ");  padding not done *)
+  test (sprintf "%S@" "foo" = "\"foo\"@");
+  test (sprintf "%S@inria.fr" "foo" = "\"foo\"@inria.fr");
+  test (sprintf "%S@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\"");
+
+  printf "\nc\n%!";
+  test (sprintf "%c" 'c' = "c");
+(*  test (sprintf "%-4c" 'c' = "c   ");    padding not done *)
+(*  test (sprintf "%04c" 'c' = "   c");    padding not done *)
+  test (sprintf "%+c" 'c' = "c");
+  test (sprintf "% c" 'c' = "c");
+  test (sprintf "%#c" 'c' = "c");
+(*  test (sprintf "%4c" 'c' = "   c");     padding not done *)
+(*  test (sprintf "%*c" 2 'c' = " c");     padding not done *)
+(*  test (sprintf "%-0+ #4c" 'c' = "c   ");  padding not done *)
+
+  printf "\nC\n%!";
+  test (sprintf "%C" 'c' = "'c'");
+  test (sprintf "%C" '\'' = "'\\''");
+(*  test (sprintf "%-4C" 'c' = "c   ");    padding not done *)
+(*  test (sprintf "%04C" 'c' = "   c");    padding not done *)
+  test (sprintf "%+C" 'c' = "'c'");
+  test (sprintf "% C" 'c' = "'c'");
+  test (sprintf "%#C" 'c' = "'c'");
+(*  test (sprintf "%4C" 'c' = "   c");     padding not done *)
+(*  test (sprintf "%*C" 2 'c' = " c");     padding not done *)
+(*  test (sprintf "%-0+ #4C" 'c' = "c   ");  padding not done *)
+
+  printf "\nf\n%!";
+  test (sprintf "%f" (-42.42) = "-42.420000");
+  test (sprintf "%-13f" (-42.42) = "-42.420000   ");
+  test (sprintf "%013f" (-42.42) = "-00042.420000");
+  test (sprintf "%+f" 42.42 = "+42.420000");
+  test (sprintf "% f" 42.42 = " 42.420000");
+  test (sprintf "%#f" 42.42 = "42.420000");
+  test (sprintf "%13f" 42.42 = "    42.420000");
+  test (sprintf "%*f" 12 42.42 = "   42.420000");
+  test (sprintf "%-0+ #12f" 42.42 = "+42.420000  ");
+  test (sprintf "%.3f" (-42.42) = "-42.420");
+  test (sprintf "%-13.3f" (-42.42) = "-42.420      ");
+  test (sprintf "%013.3f" (-42.42) = "-00000042.420");
+  test (sprintf "%+.3f" 42.42 = "+42.420");
+  test (sprintf "% .3f" 42.42 = " 42.420");
+  test (sprintf "%#.3f" 42.42 = "42.420");
+  test (sprintf "%13.3f" 42.42 = "       42.420");
+  test (sprintf "%*.*f" 12 3 42.42 = "      42.420");
+  test (sprintf "%-0+ #12.3f" 42.42 = "+42.420     ");
+
+  printf "\nF\n%!";
+  test (sprintf "%F" 42.42 = "42.42");
+  test (sprintf "%F" 42.42e42 = "4.242e+43");
+  test (sprintf "%F" 42.00 = "42.");
+  test (sprintf "%F" 0.042 = "0.042");
+(* no padding, no precision
+  test (sprintf "%.3F" 42.42 = "42.420");
+  test (sprintf "%12.3F" 42.42e42 = "   4.242e+43");
+  test (sprintf "%.3F" 42.00 = "42.000");
+  test (sprintf "%.3F" 0.0042 = "0.004");
+*)
+
+  printf "\ne\n%!";
+  test (sprintf "%e" (-42.42) = "-4.242000e+01");
+  test (sprintf "%-15e" (-42.42) = "-4.242000e+01  ");
+  test (sprintf "%015e" (-42.42) = "-004.242000e+01");
+  test (sprintf "%+e" 42.42 = "+4.242000e+01");
+  test (sprintf "% e" 42.42 = " 4.242000e+01");
+  test (sprintf "%#e" 42.42 = "4.242000e+01");
+  test (sprintf "%15e" 42.42 = "   4.242000e+01");
+  test (sprintf "%*e" 14 42.42 = "  4.242000e+01");
+  test (sprintf "%-0+ #14e" 42.42 = "+4.242000e+01 ");
+  test (sprintf "%.3e" (-42.42) = "-4.242e+01");
+  test (sprintf "%-15.3e" (-42.42) = "-4.242e+01     ");
+  test (sprintf "%015.3e" (-42.42) = "-000004.242e+01");
+  test (sprintf "%+.3e" 42.42 = "+4.242e+01");
+  test (sprintf "% .3e" 42.42 = " 4.242e+01");
+  test (sprintf "%#.3e" 42.42 = "4.242e+01");
+  test (sprintf "%15.3e" 42.42 = "      4.242e+01");
+  test (sprintf "%*.*e" 11 3 42.42 = "  4.242e+01");
+  test (sprintf "%-0+ #14.3e" 42.42 = "+4.242e+01    ");
+
+  printf "\nE\n%!";
+  test (sprintf "%E" (-42.42) = "-4.242000E+01");
+  test (sprintf "%-15E" (-42.42) = "-4.242000E+01  ");
+  test (sprintf "%015E" (-42.42) = "-004.242000E+01");
+  test (sprintf "%+E" 42.42 = "+4.242000E+01");
+  test (sprintf "% E" 42.42 = " 4.242000E+01");
+  test (sprintf "%#E" 42.42 = "4.242000E+01");
+  test (sprintf "%15E" 42.42 = "   4.242000E+01");
+  test (sprintf "%*E" 14 42.42 = "  4.242000E+01");
+  test (sprintf "%-0+ #14E" 42.42 = "+4.242000E+01 ");
+  test (sprintf "%.3E" (-42.42) = "-4.242E+01");
+  test (sprintf "%-15.3E" (-42.42) = "-4.242E+01     ");
+  test (sprintf "%015.3E" (-42.42) = "-000004.242E+01");
+  test (sprintf "%+.3E" 42.42 = "+4.242E+01");
+  test (sprintf "% .3E" 42.42 = " 4.242E+01");
+  test (sprintf "%#.3E" 42.42 = "4.242E+01");
+  test (sprintf "%15.3E" 42.42 = "      4.242E+01");
+  test (sprintf "%*.*E" 11 3 42.42 = "  4.242E+01");
+  test (sprintf "%-0+ #14.3E" 42.42 = "+4.242E+01    ");
+
+(* %g gives strange results that correspond to neither %f nor %e
+  printf "\ng\n%!";
+  test (sprintf "%g" (-42.42) = "-42.42000");
+  test (sprintf "%-15g" (-42.42) = "-42.42000      ");
+  test (sprintf "%015g" (-42.42) = "-00000042.42000");
+  test (sprintf "%+g" 42.42 = "+42.42000");
+  test (sprintf "% g" 42.42 = " 42.42000");
+  test (sprintf "%#g" 42.42 = "42.42000");
+  test (sprintf "%15g" 42.42 = "       42.42000");
+  test (sprintf "%*g" 14 42.42 = "      42.42000");
+  test (sprintf "%-0+ #14g" 42.42 = "+42.42000     ");
+  test (sprintf "%.3g" (-42.42) = "-42.420");
+*)
+
+(* Same for %G
+  printf "\nG\n%!";
+*)
+
+  printf "\nB\n%!";
+  test (sprintf "%B" true = "true");
+  test (sprintf "%B" false = "false");
+
+  printf "ld/li positive\n%!";
+  test (sprintf "%ld/%li" 42l 43l = "42/43");
+  test (sprintf "%-4ld/%-5li" 42l 43l = "42  /43   ");
+  test (sprintf "%04ld/%05li" 42l 43l = "0042/00043");
+  test (sprintf "%+ld/%+li" 42l 43l = "+42/+43");
+  test (sprintf "% ld/% li" 42l 43l = " 42/ 43");
+  test (sprintf "%#ld/%#li" 42l 43l = "42/43");
+  test (sprintf "%4ld/%5li" 42l 43l = "  42/   43");
+  test (sprintf "%*ld/%*li" 4 42l 5 43l = "  42/   43");
+  test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43  ");
+
+  printf "\nld/li negative\n%!";
+  test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43  ");
+  test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043");
+  test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43");
+  test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/  -43");
+  test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/  -43");
+  test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43  ");
+
+  printf "\nlu positive\n%!";
+  test (sprintf "%lu" 42l = "42");
+  test (sprintf "%-4lu" 42l = "42  ");
+  test (sprintf "%04lu" 42l = "0042");
+  test (sprintf "%+lu" 42l = "42");
+  test (sprintf "% lu" 42l = "42");
+  test (sprintf "%#lu" 42l = "42");
+  test (sprintf "%4lu" 42l = "  42");
+  test (sprintf "%*lu" 4 42l = "  42");
+  test (sprintf "%-0+ #6ld" 42l = "+42   ");
+
+  printf "\nlu negative\n%!";
+  test (sprintf "%lu" (-1l) = "4294967295");
+
+  printf "\nlx positive\n%!";
+  test (sprintf "%lx" 42l = "2a");
+  test (sprintf "%-4lx" 42l = "2a  ");
+  test (sprintf "%04lx" 42l = "002a");
+  test (sprintf "%+lx" 42l = "2a");
+  test (sprintf "% lx" 42l = "2a");
+  test (sprintf "%#lx" 42l = "0x2a");
+  test (sprintf "%4lx" 42l = "  2a");
+  test (sprintf "%*lx" 5 42l = "   2a");
+  test (sprintf "%-0+ #*lx" 5 42l = "0x2a ");
+
+  printf "\nlx negative\n%!";
+  test (sprintf "%lx" (-42l) = "ffffffd6");
+
+  printf "\nlX positive\n%!";
+  test (sprintf "%lX" 42l = "2A");
+  test (sprintf "%-4lX" 42l = "2A  ");
+  test (sprintf "%04lX" 42l = "002A");
+  test (sprintf "%+lX" 42l = "2A");
+  test (sprintf "% lX" 42l = "2A");
+  test (sprintf "%#lX" 42l = "0X2A");
+  test (sprintf "%4lX" 42l = "  2A");
+  test (sprintf "%*lX" 5 42l = "   2A");
+  test (sprintf "%-0+ #*lX" 5 42l = "0X2A ");
+
+  printf "\nlx negative\n%!";
+  test (sprintf "%lX" (-42l) = "FFFFFFD6");
+
+  printf "\nlo positive\n%!";
+  test (sprintf "%lo" 42l = "52");
+  test (sprintf "%-4lo" 42l = "52  ");
+  test (sprintf "%04lo" 42l = "0052");
+  test (sprintf "%+lo" 42l = "52");
+  test (sprintf "% lo" 42l = "52");
+  test (sprintf "%#lo" 42l = "052");
+  test (sprintf "%4lo" 42l = "  52");
+  test (sprintf "%*lo" 5 42l = "   52");
+  test (sprintf "%-0+ #*lo" 5 42l = "052  ");
+
+  printf "\nlo negative\n%!";
+  test (sprintf "%lo" (-42l) = "37777777726");
+
+  (* Nativeint not tested: looks like too much work, and anyway it should
+     work like Int32 or Int64. *)
+
+  printf "Ld/Li positive\n%!";
+  test (sprintf "%Ld/%Li" 42L 43L = "42/43");
+  test (sprintf "%-4Ld/%-5Li" 42L 43L = "42  /43   ");
+  test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043");
+  test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43");
+  test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43");
+  test (sprintf "%#Ld/%#Li" 42L 43L = "42/43");
+  test (sprintf "%4Ld/%5Li" 42L 43L = "  42/   43");
+  test (sprintf "%*Ld/%*Li" 4 42L 5 43L = "  42/   43");
+  test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43  ");
+
+  printf "\nLd/Li negative\n%!";
+  test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43  ");
+  test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043");
+  test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43");
+  test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/  -43");
+  test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/  -43");
+  test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43  ");
+
+  printf "\nLu positive\n%!";
+  test (sprintf "%Lu" 42L = "42");
+  test (sprintf "%-4Lu" 42L = "42  ");
+  test (sprintf "%04Lu" 42L = "0042");
+  test (sprintf "%+Lu" 42L = "42");
+  test (sprintf "% Lu" 42L = "42");
+  test (sprintf "%#Lu" 42L = "42");
+  test (sprintf "%4Lu" 42L = "  42");
+  test (sprintf "%*Lu" 4 42L = "  42");
+  test (sprintf "%-0+ #6Ld" 42L = "+42   ");
+
+  printf "\nLu negative\n%!";
+  test (sprintf "%Lu" (-1L) = "18446744073709551615");
+
+  printf "\nLx positive\n%!";
+  test (sprintf "%Lx" 42L = "2a");
+  test (sprintf "%-4Lx" 42L = "2a  ");
+  test (sprintf "%04Lx" 42L = "002a");
+  test (sprintf "%+Lx" 42L = "2a");
+  test (sprintf "% Lx" 42L = "2a");
+  test (sprintf "%#Lx" 42L = "0x2a");
+  test (sprintf "%4Lx" 42L = "  2a");
+  test (sprintf "%*Lx" 5 42L = "   2a");
+  test (sprintf "%-0+ #*Lx" 5 42L = "0x2a ");
+
+  printf "\nLx negative\n%!";
+  test (sprintf "%Lx" (-42L) = "ffffffffffffffd6");
+
+  printf "\nLX positive\n%!";
+  test (sprintf "%LX" 42L = "2A");
+  test (sprintf "%-4LX" 42L = "2A  ");
+  test (sprintf "%04LX" 42L = "002A");
+  test (sprintf "%+LX" 42L = "2A");
+  test (sprintf "% LX" 42L = "2A");
+  test (sprintf "%#LX" 42L = "0X2A");
+  test (sprintf "%4LX" 42L = "  2A");
+  test (sprintf "%*LX" 5 42L = "   2A");
+  test (sprintf "%-0+ #*LX" 5 42L = "0X2A ");
+
+  printf "\nLx negative\n%!";
+  test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6");
+
+  printf "\nLo positive\n%!";
+  test (sprintf "%Lo" 42L = "52");
+  test (sprintf "%-4Lo" 42L = "52  ");
+  test (sprintf "%04Lo" 42L = "0052");
+  test (sprintf "%+Lo" 42L = "52");
+  test (sprintf "% Lo" 42L = "52");
+  test (sprintf "%#Lo" 42L = "052");
+  test (sprintf "%4Lo" 42L = "  52");
+  test (sprintf "%*Lo" 5 42L = "   52");
+  test (sprintf "%-0+ #*Lo" 5 42L = "052  ");
+
+  printf "\nLo negative\n%!";
+  test (sprintf "%Lo" (-42L) = "1777777777777777777726");
+
+  printf "\na\n%!";
+  let x = ref () in
+  let f () y = if y == x then "ok" else "wrong" in
+  test (sprintf "%a" f x = "ok");
+
+  printf "\nt\n%!";
+  let f () = "ok" in
+  test (sprintf "%t" f = "ok");
+
+(* Does not work as expected.  Should be fixed to work like %s.
+  printf "\n{...%%}\n%!";
+  let f = format_of_string "%f/%s" in
+  test (sprintf "%{%f%s%}" f = "%f/%s");
+*)
+
+  printf "\n(...%%)\n%!";
+  let f = format_of_string "%d/foo/%s" in
+  test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar");
+
+  printf "\n! %% @ , and constants\n%!";
+  test (sprintf "%!" = "");
+  test (sprintf "%%" = "%");
+  test (sprintf "%@" = "@");
+  test (sprintf "%," = "");
+  test (sprintf "@" = "@");
+  test (sprintf "@@" = "@@");
+  test (sprintf "@%%" = "@%");
+
+  printf "\nend of tests\n%!";
+with e ->
+  printf "unexpected exception: %s\n%!" (Printexc.to_string e);
+  test false;
+;;

diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference
new file mode 100644 (file)
index 0000000..693db24
--- /dev/null
+++ b/testsuite/tests/lib-printf/tprintf.reference
@@ -0,0 +1,87 @@
+d/i positive
+0 1 2 3 4 5 6 7 8 
+d/i negative
+9 10 11 12 13 14 15 16 17 
+u positive
+18 19 20 21 22 23 24 25 26 
+u negative
+27 
+x positive
+28 29 30 31 32 33 34 35 36 
+x negative
+37 
+X positive
+38 39 40 41 42 43 44 45 46 
+x negative
+47 
+o positive
+48 49 50 51 52 53 54 55 56 
+o negative
+57 
+s
+58 59 60 61 62 63 64 65 66 67 68 69 70 71 
+S
+72 73 74 75 76 77 78 79 80 
+c
+81 82 83 84 
+C
+85 86 87 88 89 
+f
+90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 
+F
+108 109 110 111 
+e
+112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 
+E
+130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 
+B
+148 149 ld/li positive
+150 151 152 153 154 155 156 157 158 
+ld/li negative
+159 160 161 162 163 164 165 166 167 
+lu positive
+168 169 170 171 172 173 174 175 176 
+lu negative
+177 
+lx positive
+178 179 180 181 182 183 184 185 186 
+lx negative
+187 
+lX positive
+188 189 190 191 192 193 194 195 196 
+lx negative
+197 
+lo positive
+198 199 200 201 202 203 204 205 206 
+lo negative
+207 Ld/Li positive
+208 209 210 211 212 213 214 215 216 
+Ld/Li negative
+217 218 219 220 221 222 223 224 225 
+Lu positive
+226 227 228 229 230 231 232 233 234 
+Lu negative
+235 
+Lx positive
+236 237 238 239 240 241 242 243 244 
+Lx negative
+245 
+LX positive
+246 247 248 249 250 251 252 253 254 
+Lx negative
+255 
+Lo positive
+256 257 258 259 260 261 262 263 264 
+Lo negative
+265 
+a
+266 
+t
+267 
+(...%)
+268 
+! % @ , and constants
+269 270 271 272 273 274 275 
+end of tests
+
+All tests succeeded.

diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile
index 90a0ea6d1ebf5adac1d908cb92c49276104eb746..216b396301ca01fbf812f415587a4c8060cae220 100644 (file)
--- a/testsuite/tests/lib-scanf-2/Makefile
+++ b/testsuite/tests/lib-scanf-2/Makefile
@@ -1,21 +1,30 @@
+BASEDIR=../..
+
 default: compile run
 
 compile: tscanf2_io.cmo tscanf2_io.cmx
        @$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml
        @$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml
-       @$(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml
-       @$(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml; \
+         $(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml; \
+       fi
 
 run:
        @printf " ... testing with ocamlc"
        @./master.byte ./slave.byte > result.byte 2>&1
-       @diff -q reference result.byte > /dev/null || (echo " => failed" && exit 1)
-       @printf " ocamlopt"
-       @./master.native ./slave.native > result.native 2>&1
-       @diff -q reference result.native > /dev/null || (echo " => failed" && exit 1)
+       @$(DIFF) reference result.byte > /dev/null || (echo " => failed" && exit 1)
+       @if [ -z "$(BYTECODE_ONLY)" ]; then \
+         printf " ocamlopt" && \
+         ./master.native ./slave.native > result.native 2>&1 && \
+         $(DIFF) reference result.native > /dev/null || (echo " => failed" && exit 1) \
+       fi
        @echo " => passed"
 
+promote:
+       @cp result.byte reference
+
 clean: defaultclean
        @rm -f master.* slave.* result.*
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-scanf/Makefile b/testsuite/tests/lib-scanf/Makefile
index 8f8b3c5b645aed8563d996c80771473399f5f034..eba4701476e0ed342f9dda9886fb6ff2963b50a6 100644 (file)
--- a/testsuite/tests/lib-scanf/Makefile
+++ b/testsuite/tests/lib-scanf/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=tscanf
 ADD_COMPFLAGS=-I $(BASEDIR)/lib
 ADD_MODULES=testing
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml
index 89b188b4618ee970e81b1f2961b0d171250ce91e..64e144264791c31094fe056c766b0689efef04e3 100644 (file)
--- a/testsuite/tests/lib-scanf/tscanf.ml
+++ b/testsuite/tests/lib-scanf/tscanf.ml
@@ -1,6 +1,6 @@
 (*************************************************************************)
 (*                                                                       *)
-(*                            Objective Caml                             *)
+(*                                 OCaml                                 *)
 (*                                                                       *)
 (*            Pierre Weis, projet Cristal, INRIA Rocquencourt            *)
 (*                                                                       *)
@@ -585,7 +585,7 @@ and test27 () =
  (test27 ())
 ;;
 
-(* To scan a Caml string:
+(* To scan an OCaml string:
    the format is "\"%s@\"".
    A better way would be to add a %S (String.escaped), a %C (Char.escaped).
    This is now available. *)
@@ -950,7 +950,7 @@ test (test340 () && test35 ())
 
 (* The prefered reader functionnals. *)
 
-(* To read a list as in Caml (elements are ``blank + semicolon + blank''
+(* To read a list as in OCaml (elements are ``blank + semicolon + blank''
    separated, and the list is enclosed in brackets). *)
 let rec read_elems read_elem accu ib =
   kscanf ib (fun ib exc -> accu)
@@ -1444,12 +1444,22 @@ let test57 () =
 test (test57 ())
 ;;
 
-(*
 let test58 () =
+     sscanf "string1%string2" "%s@%%s" id = "string1"
+  && sscanf "string1%string2" "%s@%%%s" (^) = "string1string2"
+  && sscanf "string1@string2" "%[a-z0-9]@%s" (^) = "string1string2"
+  && sscanf "string1@%string2" "%[a-z0-9]%@%%%s" (^) = "string1string2"
 ;;
 
 test (test58 ())
 ;;
+
+(*
+let test59 () =
+;;
+
+test (test59 ())
+;;
 *)
 
 (* To be continued ...

diff --git a/testsuite/tests/lib-scanf/tscanf.reference b/testsuite/tests/lib-scanf/tscanf.reference
index edeff6725a4f4182319333e42508b16d376b334f..3c9fa44201d1872a50993b11b01abb9873202e39 100644 (file)
--- a/testsuite/tests/lib-scanf/tscanf.reference
+++ b/testsuite/tests/lib-scanf/tscanf.reference
@@ -1,2 +1,2 @@
-0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 
+0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 
 All tests succeeded.

diff --git a/testsuite/tests/lib-set/Makefile b/testsuite/tests/lib-set/Makefile
new file mode 100644 (file)
index 0000000..4ba0bff
--- /dev/null
+++ b/testsuite/tests/lib-set/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml
new file mode 100644 (file)
index 0000000..1197fbf
--- /dev/null
+++ b/testsuite/tests/lib-set/testmap.ml
@@ -0,0 +1,123 @@
+module M = Map.Make(struct type t = int let compare = compare end)
+
+let img x m = try Some(M.find x m) with Not_found -> None
+
+let testvals = [0;1;2;3;4;5;6;7;8;9]
+
+let check msg cond =
+  if not (List.for_all cond testvals) then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let checkbool msg b =
+  if not b then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let uncurry (f: 'a -> 'b -> 'c) (x, y: 'a * 'b) : 'c = f x y
+
+let test x v s1 s2 =
+
+  checkbool "is_empty"
+    (M.is_empty s1 = List.for_all (fun i -> img i s1 = None) testvals);
+
+  check "mem"
+    (fun i -> M.mem i s1 = (img i s1 <> None));
+
+  check "add"
+    (let s = M.add x v s1 in
+     fun i -> img i s = (if i = x then Some v else img i s1));
+
+  check "singleton"
+    (let s = M.singleton x v in
+     fun i -> img i s = (if i = x then Some v else None));
+
+  check "remove"
+    (let s = M.remove x s1 in
+     fun i -> img i s = (if i = x then None else img i s1));
+
+  check "merge-union"
+    (let f _ o1 o2 =
+       match o1, o2 with
+       | Some v1, Some v2 -> Some (v1 +. v2)
+       | None, _ -> o2
+       | _, None -> o1 in
+     let s = M.merge f s1 s2 in
+     fun i -> img i s = f i (img i s1) (img i s2));
+
+  check "merge-inter"
+    (let f _ o1 o2 =
+       match o1, o2 with
+       | Some v1, Some v2 -> Some (v1 -. v2)
+       | _, _ -> None in
+     let s = M.merge f s1 s2 in
+     fun i -> img i s = f i (img i s1) (img i s2));
+
+  checkbool "bindings"
+    (let rec extract = function
+       | [] -> []
+       | hd :: tl ->
+           match img hd s1 with
+           | None -> extract tl
+           | Some v ->(hd,  v) :: extract tl in
+     M.bindings s1 = extract testvals);
+
+  checkbool "for_all"
+    (let p x y = x mod 2 = 0 in
+     M.for_all p s1 = List.for_all (uncurry p) (M.bindings s1));
+
+  checkbool "exists"
+    (let p x y = x mod 3 = 0 in
+     M.exists p s1 = List.exists (uncurry p) (M.bindings s1));
+
+  checkbool "filter"
+    (let p x y = x >= 3 && x <= 6 in
+     M.bindings(M.filter p s1) = List.filter (uncurry p) (M.bindings s1));
+
+  checkbool "partition"
+    (let p x y = x >= 3 && x <= 6 in
+     let (st,sf) = M.partition p s1
+     and (lt,lf) = List.partition (uncurry p) (M.bindings s1) in
+     M.bindings st = lt && M.bindings sf = lf);
+
+  checkbool "cardinal"
+    (M.cardinal s1 = List.length (M.bindings s1));
+
+  checkbool "min_binding"
+    (try
+       let (k,v) = M.min_binding s1 in
+       img k s1 = Some v && M.for_all (fun i _ -> k <= i) s1
+     with Not_found ->
+       M.is_empty s1);
+
+  checkbool "max_binding"
+    (try
+       let (k,v) = M.max_binding s1 in
+       img k s1 = Some v && M.for_all (fun i _ -> k >= i) s1
+     with Not_found ->
+       M.is_empty s1);
+
+  checkbool "choose"
+    (try
+       let (x,v) = M.choose s1 in img x s1 = Some v
+     with Not_found ->
+       M.is_empty s1);
+
+  check "split"
+    (let (l, p, r) = M.split x s1 in
+     fun i -> 
+       if i < x then img i l = img i s1
+       else if i > x then img i r = img i s1
+       else p = img i s1)
+
+let rkey() = Random.int 10
+
+let rdata() = Random.float 1.0
+
+let rmap() =
+  let s = ref M.empty in
+  for i = 1 to Random.int 10 do s := M.add (rkey()) (rdata()) !s done;
+  !s
+
+let _ =
+  Random.init 42;
+  for i = 1 to 25000 do test (rkey()) (rdata()) (rmap()) (rmap()) done
+  

diff --git a/testsuite/tests/lib-set/testmap.reference b/testsuite/tests/lib-set/testmap.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml
new file mode 100644 (file)
index 0000000..c4ab044
--- /dev/null
+++ b/testsuite/tests/lib-set/testset.ml
@@ -0,0 +1,120 @@
+module S = Set.Make(struct type t = int let compare = compare end)
+
+let testvals = [0;1;2;3;4;5;6;7;8;9]
+
+let check msg cond =
+  if not (List.for_all cond testvals) then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let checkbool msg b =
+  if not b then
+    Printf.printf "Test %s FAILED\n%!" msg
+
+let normalize_cmp c =
+  if c = 0 then 0 else if c > 0 then 1 else -1
+
+let test x s1 s2 =
+
+  checkbool "is_empty"
+    (S.is_empty s1 = List.for_all (fun i -> not (S.mem i s1)) testvals);
+
+  check "add"
+    (let s = S.add x s1 in
+     fun i -> S.mem i s = (S.mem i s1 || i = x));
+
+  check "singleton"
+    (let s = S.singleton x in
+     fun i -> S.mem i s = (i = x));
+
+  check "remove"
+    (let s = S.remove x s1 in
+     fun i -> S.mem i s = (S.mem i s1 && i <> x));
+
+  check "union"
+    (let s = S.union s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 || S.mem i s2));
+
+  check "inter"
+    (let s = S.inter s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 && S.mem i s2));
+
+  check "diff"
+    (let s = S.diff s1 s2 in
+     fun i -> S.mem i s = (S.mem i s1 && not (S.mem i s2)));
+
+  checkbool "elements"
+    (S.elements s1 = List.filter (fun i -> S.mem i s1) testvals);
+
+  checkbool "compare"
+    (normalize_cmp (S.compare s1 s2) = normalize_cmp (compare (S.elements s1) (S.elements s2)));
+
+  checkbool "equal"
+    (S.equal s1 s2 = (S.elements s1 = S.elements s2));
+
+  check "subset"
+    (let b = S.subset s1 s2 in
+     fun i -> if b && S.mem i s1 then S.mem i s2 else true);
+
+  checkbool "subset2"
+    (let b = S.subset s1 s2 in
+     b || not (S.is_empty (S.diff s1 s2)));
+
+  checkbool "for_all"
+    (let p x = x mod 2 = 0 in
+     S.for_all p s1 = List.for_all p (S.elements s1));
+
+  checkbool "exists"
+    (let p x = x mod 3 = 0 in
+     S.exists p s1 = List.exists p (S.elements s1));
+
+  checkbool "filter"
+    (let p x = x >= 3 && x <= 6 in
+     S.elements(S.filter p s1) = List.filter p (S.elements s1));
+
+  checkbool "partition"
+    (let p x = x >= 3 && x <= 6 in
+     let (st,sf) = S.partition p s1
+     and (lt,lf) = List.partition p (S.elements s1) in
+     S.elements st = lt && S.elements sf = lf);
+
+  checkbool "cardinal"
+    (S.cardinal s1 = List.length (S.elements s1));
+
+  checkbool "min_elt"
+    (try
+       let m = S.min_elt s1 in
+       S.mem m s1 && S.for_all (fun i -> m <= i) s1
+     with Not_found ->
+       S.is_empty s1);
+
+  checkbool "max_elt"
+    (try
+       let m = S.max_elt s1 in
+       S.mem m s1 && S.for_all (fun i -> m >= i) s1
+     with Not_found ->
+       S.is_empty s1);
+
+  checkbool "choose"
+    (try
+       let x = S.choose s1 in S.mem x s1
+     with Not_found ->
+       S.is_empty s1);
+
+  check "split"
+    (let (l, p, r) = S.split x s1 in
+     fun i -> 
+       if i < x then S.mem i l = S.mem i s1
+       else if i > x then S.mem i r = S.mem i s1
+       else p = S.mem i s1)
+
+let relt() = Random.int 10
+
+let rset() =
+  let s = ref S.empty in
+  for i = 1 to Random.int 10 do s := S.add (relt()) !s done;
+  !s
+
+let _ =
+  Random.init 42;
+  for i = 1 to 25000 do test (relt()) (rset()) (rset()) done
+  

diff --git a/testsuite/tests/lib-set/testset.reference b/testsuite/tests/lib-set/testset.reference
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/testsuite/tests/lib-str/Makefile b/testsuite/tests/lib-str/Makefile
index 530ea73079eaf9e0a4082101665e3008776d3638..35ad3003dda2b39625112ec18efb1a953c903132 100644 (file)
--- a/testsuite/tests/lib-str/Makefile
+++ b/testsuite/tests/lib-str/Makefile
@@ -1,4 +1,5 @@
+BASEDIR=../..
 LIBRARIES=str
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-systhreads/Makefile b/testsuite/tests/lib-systhreads/Makefile
index 80138b26ce535bfe0d2c66b91ab7f55682abbebe..8729461a7799e2a3993f8383d49a51d94ce79fa3 100644 (file)
--- a/testsuite/tests/lib-systhreads/Makefile
+++ b/testsuite/tests/lib-systhreads/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 LIBRARIES=unix threads
 ADD_COMPFLAGS=-thread
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/lib-threads/.cvsignore b/testsuite/tests/lib-threads/.cvsignore
deleted file mode 100644 (file)
index e6d9e45..0000000
--- a/testsuite/tests/lib-threads/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-*.byt

diff --git a/testsuite/tests/lib-threads/.ignore b/testsuite/tests/lib-threads/.ignore
new file mode 100644 (file)
index 0000000..e6d9e45
--- /dev/null
+++ b/testsuite/tests/lib-threads/.ignore
@@ -0,0 +1 @@
+*.byt

diff --git a/testsuite/tests/lib-threads/Makefile b/testsuite/tests/lib-threads/Makefile
index 80138b26ce535bfe0d2c66b91ab7f55682abbebe..8729461a7799e2a3993f8383d49a51d94ce79fa3 100644 (file)
--- a/testsuite/tests/lib-threads/Makefile
+++ b/testsuite/tests/lib-threads/Makefile
@@ -1,5 +1,6 @@
+BASEDIR=../..
 LIBRARIES=unix threads
 ADD_COMPFLAGS=-thread
 
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/misc-kb/Makefile b/testsuite/tests/misc-kb/Makefile
index b5f5eaec971ff544b13e574e90fe0fcf44450b97..1802e554e38ad6f0d9c8c854f464fd12a816b380 100644 (file)
--- a/testsuite/tests/misc-kb/Makefile
+++ b/testsuite/tests/misc-kb/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 MODULES=terms equations orderings kb
 MAIN_MODULE=kbmain
 ADD_COMPFLAGS=-w a
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/misc-kb/equations.ml b/testsuite/tests/misc-kb/equations.ml
index a7ea9a03b64b474333ad66c8b532475e31974772..5617bc4f9d23681d5b58dc0bb77cb4db7472bc15 100644 (file)
--- a/testsuite/tests/misc-kb/equations.ml
+++ b/testsuite/tests/misc-kb/equations.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-kb/equations.mli b/testsuite/tests/misc-kb/equations.mli
index 45d790260fd5d8db3c0ed31af887543bcec2736c..0db190b858af2be928d319c2bfaf840353faabfd 100644 (file)
--- a/testsuite/tests/misc-kb/equations.mli
+++ b/testsuite/tests/misc-kb/equations.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-kb/kb.ml b/testsuite/tests/misc-kb/kb.ml
index 590f4cd5d007480088e3a06bfafdf5f5b44beae6..ff357b3ff86f88647b71a6ab7a31d66885b44cef 100644 (file)
--- a/testsuite/tests/misc-kb/kb.ml
+++ b/testsuite/tests/misc-kb/kb.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-kb/kb.mli b/testsuite/tests/misc-kb/kb.mli
index 59b60e4ea2916e90c42bec18481713ed42d94a1f..27aa2e9862e737b7a4fa61f7512cbee458899f6f 100644 (file)
--- a/testsuite/tests/misc-kb/kb.mli
+++ b/testsuite/tests/misc-kb/kb.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-kb/kbmain.ml b/testsuite/tests/misc-kb/kbmain.ml
index 0a5da2fb63981addf99209233841668bf80078af..580b71504031de7a96cb5cd9b6b05b427e741400 100644 (file)
--- a/testsuite/tests/misc-kb/kbmain.ml
+++ b/testsuite/tests/misc-kb/kbmain.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-kb/orderings.ml b/testsuite/tests/misc-kb/orderings.ml
index 11a776ba7c886ee3028ceb17a864d8c8153ea97b..c81746e30931627d3276ed4946ec91a7d27f4765 100644 (file)
--- a/testsuite/tests/misc-kb/orderings.ml
+++ b/testsuite/tests/misc-kb/orderings.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-kb/orderings.mli b/testsuite/tests/misc-kb/orderings.mli
index d7abfd56456da2584e3723eb2f13ee1871c37584..bb44f0832dc4eb3393e029647dfe33a7d06b9fb7 100644 (file)
--- a/testsuite/tests/misc-kb/orderings.mli
+++ b/testsuite/tests/misc-kb/orderings.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-kb/terms.ml b/testsuite/tests/misc-kb/terms.ml
index dba7000646464a849fc623b4dfa2d911bb235d81..86604f9c5a6592dbc340a6decc73f57ce50ade45 100644 (file)
--- a/testsuite/tests/misc-kb/terms.ml
+++ b/testsuite/tests/misc-kb/terms.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-kb/terms.mli b/testsuite/tests/misc-kb/terms.mli
index 7d22e9cb0009dd17b2e564e56c998befbdf0a1e3..0f6be4c8e8c655c209e9e29a277aeb354c06cd23 100644 (file)
--- a/testsuite/tests/misc-kb/terms.mli
+++ b/testsuite/tests/misc-kb/terms.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-unsafe/Makefile b/testsuite/tests/misc-unsafe/Makefile
index 82f7a72d659ee380326e411266fa487136e57cb6..f4a8b4e3b1094201042d92d22c33133e1153749b 100644 (file)
--- a/testsuite/tests/misc-unsafe/Makefile
+++ b/testsuite/tests/misc-unsafe/Makefile
@@ -1,3 +1,4 @@
+BASEDIR=../..
 UNSAFE=ON
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/misc-unsafe/almabench.ml b/testsuite/tests/misc-unsafe/almabench.ml
index b21304729622d2aa559feaf49923a1a57a168e2c..73293e9ad9fe0ccf6174ba133ba8bac208213dbe 100644 (file)
--- a/testsuite/tests/misc-unsafe/almabench.ml
+++ b/testsuite/tests/misc-unsafe/almabench.ml
@@ -1,6 +1,6 @@
 (*
  * ALMABENCH 1.0.1
- * Objective Caml version
+ *      OCaml     version
  *
  *     A number-crunching benchmark designed for cross-language and vendor
  *     comparisons.

diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml
index 0907cdee3c2d56c9f65cc0fabc26be1c324e4f9b..f0a2ed3289ec9caf01e29431a8295b365b0b6df3 100644 (file)
--- a/testsuite/tests/misc-unsafe/fft.ml
+++ b/testsuite/tests/misc-unsafe/fft.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml
index 7449488d2ded34c0ab4c5ba2536231d65f7338dd..d5d8fb4dd347485a6c20ed0113b79561323077cb 100644 (file)
--- a/testsuite/tests/misc-unsafe/quicksort.ml
+++ b/testsuite/tests/misc-unsafe/quicksort.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc-unsafe/soli.ml b/testsuite/tests/misc-unsafe/soli.ml
index aba79b15b8dc87105e076f471c012fe5c3bf1e98..163939860868e33ec259b731fc1ddb606f6fa4a3 100644 (file)
--- a/testsuite/tests/misc-unsafe/soli.ml
+++ b/testsuite/tests/misc-unsafe/soli.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc/Makefile b/testsuite/tests/misc/Makefile
index a226dd11fc1d32b20b703928752d25a6a5fb3f42..4ba0bffc51a49617bbbe56f5150b18b6313711fa 100644 (file)
--- a/testsuite/tests/misc/Makefile
+++ b/testsuite/tests/misc/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml
index 8452b8c6453b04757e03c1451162d6270eff5069..b2a3d7059917780d1bff6f14d345338ae47d3419 100644 (file)
--- a/testsuite/tests/misc/bdd.ml
+++ b/testsuite/tests/misc/bdd.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-(* Translated to Caml by Xavier Leroy *)
+(* Translated to OCaml by Xavier Leroy *)
 (* Original code written in SML by ... *)
 
 type bdd = One | Zero | Node of bdd * int * int * bdd

diff --git a/testsuite/tests/misc/boyer.ml b/testsuite/tests/misc/boyer.ml
index c5e829ff2cf99cfefecc74470a2f86c9a476c34d..4f4e0813009ab3202e785ca36ff4bf9b013292f0 100644 (file)
--- a/testsuite/tests/misc/boyer.ml
+++ b/testsuite/tests/misc/boyer.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc/fib.ml b/testsuite/tests/misc/fib.ml
index 7fad4bfdbc970b66efabcbf0a02e6970aa48c1fb..4160004ea45f396df391b5c9631c7d0aa7d42475 100644 (file)
--- a/testsuite/tests/misc/fib.ml
+++ b/testsuite/tests/misc/fib.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc/hamming.ml b/testsuite/tests/misc/hamming.ml
index 7216ddb0d978d11a8ab03316d03becb71bd73946..872454401c56cc93173ce191e182f0180e11f2d8 100644 (file)
--- a/testsuite/tests/misc/hamming.ml
+++ b/testsuite/tests/misc/hamming.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc/nucleic.ml b/testsuite/tests/misc/nucleic.ml
index e3adfd6228d58dc8e37c81ea0973150418be52d9..b35360a8827d33a9e86bf0f5edd063d2da44a530 100644 (file)
--- a/testsuite/tests/misc/nucleic.ml
+++ b/testsuite/tests/misc/nucleic.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc/sieve.ml b/testsuite/tests/misc/sieve.ml
index 994a4087d3220d12c1586221fc4b0829cb9da8d8..7f0295bb674fa5e4802beda878939d5dfbce9c30 100644 (file)
--- a/testsuite/tests/misc/sieve.ml
+++ b/testsuite/tests/misc/sieve.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc/takc.ml b/testsuite/tests/misc/takc.ml
index 8e49f24849438ce16ede59ac972107d7ea1bb686..8f9400ebdfa86b237608d7772bc5df43de7f3e43 100644 (file)
--- a/testsuite/tests/misc/takc.ml
+++ b/testsuite/tests/misc/takc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/misc/taku.ml b/testsuite/tests/misc/taku.ml
index 555fb01c8609f71f9e02eb31a2e7df4dd6ec2c6f..31e617eed70f3ff91edc53a0580a450a671fae58 100644 (file)
--- a/testsuite/tests/misc/taku.ml
+++ b/testsuite/tests/misc/taku.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/prim-revapply/Makefile b/testsuite/tests/prim-revapply/Makefile
new file mode 100644 (file)
index 0000000..bcc2fdb
--- /dev/null
+++ b/testsuite/tests/prim-revapply/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml
new file mode 100644 (file)
index 0000000..1a169e1
--- /dev/null
+++ b/testsuite/tests/prim-revapply/apply.ml
@@ -0,0 +1,36 @@
+external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      f @@ 3; (* 6 *)
+      g @@ f @@ 3; (* 36 *)
+      f @@ g @@ 3; (* 18 *)
+      h @@ g @@ f @@ 3; (* 37 *)
+      add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *)
+    ]
+external ( @@ ) :  ('a -> 'b) -> 'a -> 'b = "%apply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      f @@ 3; (* 6 *)
+      g @@ f @@ 3; (* 36 *)
+      f @@ g @@ 3; (* 18 *)
+      h @@ g @@ f @@ 3; (* 37 *)
+      add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *)
+    ]

diff --git a/testsuite/tests/prim-revapply/apply.reference b/testsuite/tests/prim-revapply/apply.reference
new file mode 100644 (file)
index 0000000..07fc0dc
--- /dev/null
+++ b/testsuite/tests/prim-revapply/apply.reference
@@ -0,0 +1,10 @@
+6
+36
+18
+37
+260
+6
+36
+18
+37
+260

diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml
new file mode 100644 (file)
index 0000000..f8b0dc2
--- /dev/null
+++ b/testsuite/tests/prim-revapply/revapply.ml
@@ -0,0 +1,18 @@
+external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+
+let f x = x + x
+let g x = x * x
+let h x = x + 1
+let add x y = x + y
+
+let _ =
+  List.iter (fun x ->
+    print_int x; print_newline ()
+  )
+    [
+      3 |> f; (* 6 *)
+      3 |> f |> g; (* 36 *)
+      3 |> g |> f; (* 18 *)
+      3 |> f |> g |> h; (* 37 *)
+      3 |> add 2 |> add 3 |> f |> g |> add 4; (* 260 *)
+    ]

diff --git a/testsuite/tests/prim-revapply/revapply.reference b/testsuite/tests/prim-revapply/revapply.reference
new file mode 100644 (file)
index 0000000..fbca442
--- /dev/null
+++ b/testsuite/tests/prim-revapply/revapply.reference
@@ -0,0 +1,5 @@
+6
+36
+18
+37
+260

diff --git a/testsuite/tests/regression-camlp4-class-type-plus/Makefile b/testsuite/tests/regression-camlp4-class-type-plus/Makefile
deleted file mode 100644 (file)
index 95106ce..0000000
--- a/testsuite/tests/regression-camlp4-class-type-plus/Makefile
+++ /dev/null
@@ -1,5 +0,0 @@
-ADD_COMPFLAGS = -pp 'camlp4o'
-MAIN_MODULE = camlp4_class_type_plus_ok
-
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common

diff --git a/testsuite/tests/regression-camlp4-class-type-plus/camlp4_class_type_plus_ok.ml b/testsuite/tests/regression-camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
deleted file mode 100644 (file)
index 79ba26d..0000000
--- a/testsuite/tests/regression-camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-type t;;
-type xdr_value;;
-
-class type [ 't ] engine = object
-end;;
-
-module type T = sig
-class unbound_async_call : t -> [xdr_value] engine;;
-end;;

diff --git a/testsuite/tests/regression-pr5080-notes/Makefile b/testsuite/tests/regression-pr5080-notes/Makefile
deleted file mode 100644 (file)
index 149c289..0000000
--- a/testsuite/tests/regression-pr5080-notes/Makefile
+++ /dev/null
@@ -1,5 +0,0 @@
-ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
-MAIN_MODULE = pr5080_notes_ok
-
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common

diff --git a/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml
deleted file mode 100644 (file)
index 175bc8b..0000000
--- a/testsuite/tests/regression-pr5080-notes/pr5080_notes_ok.ml
+++ /dev/null
@@ -1,4 +0,0 @@
-let marshal_int f  =
-  match [] with
-  | _ :: `INT n :: _ -> f n
-  | _ -> failwith "marshal_int"

diff --git a/testsuite/tests/regression/camlp4-class-type-plus/Makefile b/testsuite/tests/regression/camlp4-class-type-plus/Makefile
new file mode 100644 (file)
index 0000000..a539d51
--- /dev/null
+++ b/testsuite/tests/regression/camlp4-class-type-plus/Makefile
@@ -0,0 +1,5 @@
+ADD_COMPFLAGS = -pp 'camlp4o'
+MAIN_MODULE = camlp4_class_type_plus_ok
+
+include ../../../makefiles/Makefile.okbad
+include ../../../makefiles/Makefile.common

diff --git a/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml b/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
new file mode 100644 (file)
index 0000000..79ba26d
--- /dev/null
+++ b/testsuite/tests/regression/camlp4-class-type-plus/camlp4_class_type_plus_ok.ml
@@ -0,0 +1,9 @@
+type t;;
+type xdr_value;;
+
+class type [ 't ] engine = object
+end;;
+
+module type T = sig
+class unbound_async_call : t -> [xdr_value] engine;;
+end;;

diff --git a/testsuite/tests/regression/pr5080-notes/Makefile b/testsuite/tests/regression/pr5080-notes/Makefile
new file mode 100644 (file)
index 0000000..ddc4d55
--- /dev/null
+++ b/testsuite/tests/regression/pr5080-notes/Makefile
@@ -0,0 +1,5 @@
+ADD_COMPFLAGS = -pp 'camlp4o pa_macro.cmo'
+MAIN_MODULE = pr5080_notes_ok
+
+include ../../../makefiles/Makefile.okbad
+include ../../../makefiles/Makefile.common

diff --git a/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
new file mode 100644 (file)
index 0000000..175bc8b
--- /dev/null
+++ b/testsuite/tests/regression/pr5080-notes/pr5080_notes_ok.ml
@@ -0,0 +1,4 @@
+let marshal_int f  =
+  match [] with
+  | _ :: `INT n :: _ -> f n
+  | _ -> failwith "marshal_int"

diff --git a/testsuite/tests/runtime-errors/.ignore b/testsuite/tests/runtime-errors/.ignore
new file mode 100644 (file)
index 0000000..fa628ea
--- /dev/null
+++ b/testsuite/tests/runtime-errors/.ignore
@@ -0,0 +1 @@
+*.bytecode

diff --git a/testsuite/tests/runtime-errors/.svnignore b/testsuite/tests/runtime-errors/.svnignore
deleted file mode 100755 (executable)
index ceeffd0..0000000
--- a/testsuite/tests/runtime-errors/.svnignore
+++ /dev/null
@@ -1,11 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-*.bytecode
-
-EOF

diff --git a/testsuite/tests/runtime-errors/Makefile b/testsuite/tests/runtime-errors/Makefile
index 4945c1f805a866557a7118dafa290cc3cd6a94f2..249a1bbf7440e2f634646183fc1efd9eb158b5fc 100644 (file)
--- a/testsuite/tests/runtime-errors/Makefile
+++ b/testsuite/tests/runtime-errors/Makefile
@@ -1,25 +1,32 @@
+BASEDIR=../..
+
 default: compile run
 
 compile:
        @for f in *.ml; do \
          $(OCAMLC) -w a -o `basename $$f ml`bytecode $$f; \
-         $(OCAMLOPT) -w a -o `basename $$f ml`native $$f; \
+         test -z "$(BYTECODE_ONLY)" && $(OCAMLOPT) -w a -o `basename $$f ml`native $$f || true; \
        done
        @if [ ! `grep -c HAS_STACK_OVERFLOW_DETECTION ../../../config/s.h` ]; then \
-         rm -f stackoverflow.byte stackoverflow.native; \
+         test -z "$(BYTECODE_ONLY)" && rm -f stackoverflow.byte stackoverflow.native || true; \
        fi
 
 run:
-       @for f in *.bytecode; do \
+       @ulimit -s 1024; \
+         for f in *.bytecode; do \
          printf " ... testing '$$f':"; \
          (./$$f > $$f.result 2>&1; true); \
-         diff -q $$f.reference $$f.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
-         printf " ... testing '`basename $$f bytecode`native':"; \
-         (./`basename $$f bytecode`native > `basename $$f bytecode`native.result 2>&1; true); \
-         diff -q `basename $$f bytecode`native.reference `basename $$f bytecode`native.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
+         $(DIFF) $$f.reference $$f.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
+         if [ -z "$(BYTECODE_ONLY)" ]; then \
+           printf " ... testing '`basename $$f bytecode`native':"; \
+           (./`basename $$f bytecode`native > `basename $$f bytecode`native.result 2>&1; true); \
+           $(DIFF) `basename $$f bytecode`native.reference `basename $$f bytecode`native.result > /dev/null || (echo " => failed" && exit 1) && echo " => passed"; \
+         fi; \
        done
 
+promote: defaultpromote
+
 clean: defaultclean
        @rm -f *.bytecode *.native *.result
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference b/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
index 745f81aef725031bf23f5bf3f1e11e479d4239a1..a5bbdea33c8f82323cf17dd596ddc9f3672453c8 100644 (file)
--- a/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
+++ b/testsuite/tests/runtime-errors/stackoverflow.bytecode.reference
@@ -1,5 +1,4 @@
-x = 196608
-x = 131072
-x = 65536
+x = 20000
+x = 10000
 x = 0
 Stack overflow caught

diff --git a/testsuite/tests/runtime-errors/stackoverflow.ml b/testsuite/tests/runtime-errors/stackoverflow.ml
index 4d211bc828c2593a931e8ec27f7a6e9129370fec..ab53b8b068eac9122464a165f67a92568bbc2768 100644 (file)
--- a/testsuite/tests/runtime-errors/stackoverflow.ml
+++ b/testsuite/tests/runtime-errors/stackoverflow.ml
@@ -1,5 +1,5 @@
 let rec f x =
-  if x land 0xFFFF <> 0
+  if not (x = 0 || x = 10000 || x = 20000)
   then 1 + f (x + 1)
   else
     try

diff --git a/testsuite/tests/runtime-errors/stackoverflow.native.reference b/testsuite/tests/runtime-errors/stackoverflow.native.reference
index 835095c58eff0c6ff440fcbcb5c908551ebfc304..a5bbdea33c8f82323cf17dd596ddc9f3672453c8 100644 (file)
--- a/testsuite/tests/runtime-errors/stackoverflow.native.reference
+++ b/testsuite/tests/runtime-errors/stackoverflow.native.reference
@@ -1,65 +1,4 @@
-x = 4128768
-x = 4063232
-x = 3997696
-x = 3932160
-x = 3866624
-x = 3801088
-x = 3735552
-x = 3670016
-x = 3604480
-x = 3538944
-x = 3473408
-x = 3407872
-x = 3342336
-x = 3276800
-x = 3211264
-x = 3145728
-x = 3080192
-x = 3014656
-x = 2949120
-x = 2883584
-x = 2818048
-x = 2752512
-x = 2686976
-x = 2621440
-x = 2555904
-x = 2490368
-x = 2424832
-x = 2359296
-x = 2293760
-x = 2228224
-x = 2162688
-x = 2097152
-x = 2031616
-x = 1966080
-x = 1900544
-x = 1835008
-x = 1769472
-x = 1703936
-x = 1638400
-x = 1572864
-x = 1507328
-x = 1441792
-x = 1376256
-x = 1310720
-x = 1245184
-x = 1179648
-x = 1114112
-x = 1048576
-x = 983040
-x = 917504
-x = 851968
-x = 786432
-x = 720896
-x = 655360
-x = 589824
-x = 524288
-x = 458752
-x = 393216
-x = 327680
-x = 262144
-x = 196608
-x = 131072
-x = 65536
+x = 20000
+x = 10000
 x = 0
 Stack overflow caught

diff --git a/testsuite/tests/tool-lexyacc/.ignore b/testsuite/tests/tool-lexyacc/.ignore
new file mode 100644 (file)
index 0000000..6bcc851
--- /dev/null
+++ b/testsuite/tests/tool-lexyacc/.ignore
@@ -0,0 +1,3 @@
+scanner.ml
+grammar.mli
+grammar.ml

diff --git a/testsuite/tests/tool-lexyacc/.svnignore b/testsuite/tests/tool-lexyacc/.svnignore
deleted file mode 100644 (file)
index 3670600..0000000
--- a/testsuite/tests/tool-lexyacc/.svnignore
+++ /dev/null
@@ -1,13 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-scanner.ml
-grammar.mli
-grammar.ml
-
-EOF

diff --git a/testsuite/tests/tool-lexyacc/Makefile b/testsuite/tests/tool-lexyacc/Makefile
index b9260a5453164ff611cf5f6cc4ea99f71538477b..3d7f49be9f017cd82d6053ecc48e944be178c72f 100644 (file)
--- a/testsuite/tests/tool-lexyacc/Makefile
+++ b/testsuite/tests/tool-lexyacc/Makefile
@@ -1,3 +1,4 @@
+BASEDIR=../..
 MODULES=syntax gram_aux grammar scan_aux scanner lexgen output
 MAIN_MODULE=main
 LEX_MODULES=scanner
@@ -5,5 +6,5 @@ YACC_MODULES=grammar
 ADD_COMPFLAGS=-w a
 EXEC_ARGS=input
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/tool-lexyacc/gram_aux.ml b/testsuite/tests/tool-lexyacc/gram_aux.ml
index b84d8588a6545c9ce0d9fe6b7385e82e3c9f0df6..c00fa9bfe167d67ce11e88794356afc1b3753938 100644 (file)
--- a/testsuite/tests/tool-lexyacc/gram_aux.ml
+++ b/testsuite/tests/tool-lexyacc/gram_aux.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/tool-lexyacc/grammar.mly b/testsuite/tests/tool-lexyacc/grammar.mly
index 8c1e4db943d198c7d4b357173090bc2784559926..8d1346f8e30ca8f8c9e29cd607d3d69dc63b6995 100644 (file)
--- a/testsuite/tests/tool-lexyacc/grammar.mly
+++ b/testsuite/tests/tool-lexyacc/grammar.mly
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/testsuite/tests/tool-lexyacc/input b/testsuite/tests/tool-lexyacc/input
index 6793cb8745bcebfebbb57b8bdd0711044d8faac6..b6fdfee8dfe819e4d58cffff8bd01cd4f7684c7c 100644 (file)
--- a/testsuite/tests/tool-lexyacc/input
+++ b/testsuite/tests/tool-lexyacc/input
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml
index bbd729b0f14478b9f9f4b22d5f89c85de34b920c..d4b6f9a96e311d79f5726d46ed2bd03a9574318a 100644 (file)
--- a/testsuite/tests/tool-lexyacc/lexgen.ml
+++ b/testsuite/tests/tool-lexyacc/lexgen.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/tool-lexyacc/main.ml b/testsuite/tests/tool-lexyacc/main.ml
index d18a4886d2c4fdbbd843f13f52fa65bfe495183e..a9337d4b9b1d6f6a452140f8af7f27b3d0a39382 100644 (file)
--- a/testsuite/tests/tool-lexyacc/main.ml
+++ b/testsuite/tests/tool-lexyacc/main.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/tool-lexyacc/output.ml b/testsuite/tests/tool-lexyacc/output.ml
index 09c66b687324d46162988ab657bba10bf723ba95..141510c4451ee6d7f51f6f00e0cd5f0e5bceed42 100644 (file)
--- a/testsuite/tests/tool-lexyacc/output.ml
+++ b/testsuite/tests/tool-lexyacc/output.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/tool-lexyacc/scan_aux.ml b/testsuite/tests/tool-lexyacc/scan_aux.ml
index c449b13a5991d4535d996608d5659fe3c3ea2151..7c796f353c34d4e781f1ecdd7ec8d8106a345eb9 100644 (file)
--- a/testsuite/tests/tool-lexyacc/scan_aux.ml
+++ b/testsuite/tests/tool-lexyacc/scan_aux.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/tool-lexyacc/scanner.mll b/testsuite/tests/tool-lexyacc/scanner.mll
index 131272fdd4492e77c2dae62d96d273e636d7ae8b..f791feaf24bfc2689a8cd1d036e1705311def46e 100644 (file)
--- a/testsuite/tests/tool-lexyacc/scanner.mll
+++ b/testsuite/tests/tool-lexyacc/scanner.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/tool-lexyacc/syntax.ml b/testsuite/tests/tool-lexyacc/syntax.ml
index ff704cd2f0650fe464bf5743d1e81bb2bc1e55bc..e2ff025eee4530d125d4345aab106018e7f5561c 100644 (file)
--- a/testsuite/tests/tool-lexyacc/syntax.ml
+++ b/testsuite/tests/tool-lexyacc/syntax.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/testsuite/tests/tool-ocaml/Makefile b/testsuite/tests/tool-ocaml/Makefile
index 2b2940fba105103e8e5b43c2cc9a0ed00e9f4224..312fac5bd2f3e8f8b85abead3871389c722693cf 100644 (file)
--- a/testsuite/tests/tool-ocaml/Makefile
+++ b/testsuite/tests/tool-ocaml/Makefile
@@ -1,3 +1,4 @@
+BASEDIR=../..
 SHOULD_FAIL=t060-raise.ml
 
 compile: lib.cmo
@@ -10,7 +11,9 @@ compile: lib.cmo
          fi; \
        done
 
+promote:
+
 clean: defaultclean
        @rm -f ./a.out
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/tool-ocaml/t240-c_call3.ml b/testsuite/tests/tool-ocaml/t240-c_call3.ml
index 707bc7eec608a3b40f8033b5b97ae419f0c97758..a34e1dcf961f74a9f8847277da90cf7146c4a16e 100644 (file)
--- a/testsuite/tests/tool-ocaml/t240-c_call3.ml
+++ b/testsuite/tests/tool-ocaml/t240-c_call3.ml
@@ -1,5 +1,5 @@
 open Lib;;
-if Hashtbl.hash_param 5 6 [1;2;3] <> 196799 then raise Not_found;;
+if Hashtbl.hash_param 5 6 [1;2;3] <> 697606130 then raise Not_found;;
 
 (**
        0 CONSTINT 42

diff --git a/testsuite/tests/tool-ocamldoc/.ignore b/testsuite/tests/tool-ocamldoc/.ignore
new file mode 100644 (file)
index 0000000..866d4be
--- /dev/null
+++ b/testsuite/tests/tool-ocamldoc/.ignore
@@ -0,0 +1,4 @@
+*.html
+*.sty
+*.css
+ocamldoc.out

diff --git a/testsuite/tests/tool-ocamldoc/.svnignore b/testsuite/tests/tool-ocamldoc/.svnignore
deleted file mode 100755 (executable)
index eee23b6..0000000
--- a/testsuite/tests/tool-ocamldoc/.svnignore
+++ /dev/null
@@ -1,14 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-ocamldoc.sty
-ocamldoc.out
-style.css
-*.html
-
-EOF

diff --git a/testsuite/tests/tool-ocamldoc/Makefile b/testsuite/tests/tool-ocamldoc/Makefile
index 5e7398ba7d7e02626abeda8a2cf81e65bb804ebe..d112f568cdce934bb6582dcc56c1dbd571e00270 100644 (file)
--- a/testsuite/tests/tool-ocamldoc/Makefile
+++ b/testsuite/tests/tool-ocamldoc/Makefile
@@ -1,17 +1,19 @@
+BASEDIR=../..
 CUSTOM_MODULE=odoc_test
 ADD_COMPFLAGS=-I +ocamldoc
 
 run: $(CUSTOM_MODULE).cmo
        @for file in t*.ml; do \
          printf " ... testing '$$file'"; \
-         $(OCAMLDOC) -g $(CUSTOM_MODULE).cmo -o `basename $$file ml`result $$file; \
-         diff -q `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
+         $(OCAMLDOC) -hide-warnings -g $(CUSTOM_MODULE).cmo -o `basename $$file ml`result $$file; \
+         $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || (echo " => failed" && exit 1); \
        done;
-       @$(OCAMLDOC) -html t*.ml 2>&1 | grep -v test_types_display || true
-       @$(OCAMLDOC) -latex t*.ml 2>&1 | grep -v test_types_display || true
+       @$(OCAMLDOC) -hide-warnings -html t*.ml 2>&1 | grep -v test_types_display || true
+       @$(OCAMLDOC) -hide-warnings -latex t*.ml 2>&1 | grep -v test_types_display || true
 
+promote: defaultpromote
 
 clean: defaultclean
        @rm -f *.result *.html *.tex *.log *.out *.sty *.toc *.css *.aux
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/tool-ocamldoc/odoc_test.ml b/testsuite/tests/tool-ocamldoc/odoc_test.ml
index ba73fe52edbffee0037bb28ea9ba55d803e30a77..b5cc55626bfd833543d2bca7c23d3336c099c4bc 100644 (file)
--- a/testsuite/tests/tool-ocamldoc/odoc_test.ml
+++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml
@@ -88,7 +88,7 @@ class string_gen =
       true
 
     method generate (module_list: Odoc_info.Module.t_module list) =
-      let oc = open_out !Odoc_info.Args.out_file in
+      let oc = open_out !Odoc_info.Global.out_file in
       fmt <- Format.formatter_of_out_channel oc;
       (
        try
@@ -106,7 +106,12 @@ class string_gen =
       close_out oc
   end
 
-
-let my_generator = new string_gen
-let _ = Odoc_info.Args.set_doc_generator 
-    (Some (my_generator :> Odoc_info.Args.doc_generator))
+let _ =
+  let module My_generator = struct
+    class generator =
+    let inst = new string_gen in
+    object
+      method generate = inst#generate
+    end
+  end in
+  Odoc_args.set_generator (Odoc_gen.Base (module My_generator : Odoc_gen.Base))

diff --git a/testsuite/tests/typing-fstclassmod/.svnignore b/testsuite/tests/typing-fstclassmod/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/typing-fstclassmod/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/typing-fstclassmod/Makefile b/testsuite/tests/typing-fstclassmod/Makefile
index a8a96229107c502621948be4235d8068c26f1ea2..ea38ed37b336e22785d6bc98d2d64d6e7291ee5f 100644 (file)
--- a/testsuite/tests/typing-fstclassmod/Makefile
+++ b/testsuite/tests/typing-fstclassmod/Makefile
@@ -1,6 +1,7 @@
+BASEDIR=../..
 #MODULES=
 MAIN_MODULE=fstclassmod
 ADD_COMPFLAGS=-w a
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-gadts/Makefile b/testsuite/tests/typing-gadts/Makefile
new file mode 100644 (file)
index 0000000..9add155
--- /dev/null
+++ b/testsuite/tests/typing-gadts/Makefile
@@ -0,0 +1,3 @@
+include ../../makefiles/Makefile.toplevel
+include ../../makefiles/Makefile.common
+

diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml b/testsuite/tests/typing-gadts/dynamic_frisch.ml
new file mode 100644 (file)
index 0000000..895be5a
--- /dev/null
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml
@@ -0,0 +1,475 @@
+(* Encoding generics using GADTs *)
+(* (c) Alain Frisch / Lexifi *)
+(* cf. http://www.lexifi.com/blog/dynamic-types *)
+
+(* Basic tag *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+;;
+
+(* Tagging data *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+ 
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+ 
+exception VariantMismatch
+ 
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | _ -> raise VariantMismatch
+;;
+
+(* Handling records *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: 'a record -> 'a ty
+ 
+and 'a record =
+    {
+     path: string;
+     fields: 'a field_ list;
+    }
+ 
+and 'a field_ =
+  | Field: ('a, 'b) field -> 'a field_
+ 
+and ('a, 'b) field =
+    {
+     label: string;
+     field_type: 'b ty;
+     get: ('a -> 'b);
+    }
+;;
+
+(* Again *)
+
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+
+let rec variantize: type t. t ty -> t -> variant =
+  fun ty x ->
+    (* type t is abstract here *)
+    match ty with
+    | Int -> VInt x  (* in this branch: t = int *)
+    | String -> VString x (* t = string *)
+    | List ty1 ->
+        VList (List.map (variantize ty1) x)
+        (* t = 'a list for some 'a *)
+    | Pair (ty1, ty2) ->
+        VPair (variantize ty1 (fst x), variantize ty2 (snd x))
+        (* t = ('a, 'b) for some 'a and 'b *)
+    | Record {fields} ->
+        VRecord
+          (List.map (fun (Field{field_type; label; get}) ->
+                       (label, variantize field_type (get x))) fields)
+;;
+ 
+(* Extraction *)
+
+type 'a ty =
+  | Int: int ty
+  | String: string ty
+  | List: 'a ty -> 'a list ty
+  | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record: ('a, 'builder) record -> 'a ty
+ 
+and ('a, 'builder) record =
+    {
+     path: string;
+     fields: ('a, 'builder) field list;
+     create_builder: (unit -> 'builder);
+     of_builder: ('builder -> 'a);
+    }
+ 
+and ('a, 'builder) field =
+  | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+ 
+and ('a, 'builder, 'b) field_ =
+  {
+   label: string;
+   field_type: 'b ty;
+   get: ('a -> 'b);
+   set: ('builder -> 'b -> unit);
+  }
+ 
+let rec devariantize: type t. t ty -> variant -> t =
+  fun ty v ->
+    match ty, v with
+    | Int, VInt x -> x
+    | String, VString x -> x
+    | List ty1, VList vl ->
+        List.map (devariantize ty1) vl
+    | Pair (ty1, ty2), VPair (x1, x2) ->
+        (devariantize ty1 x1, devariantize ty2 x2)
+    | Record {fields; create_builder; of_builder}, VRecord fl ->
+        if List.length fields <> List.length fl then raise VariantMismatch;
+        let builder = create_builder () in
+        List.iter2
+          (fun (Field {label; field_type; set}) (lab, v) ->
+            if label <> lab then raise VariantMismatch;
+            set builder (devariantize field_type v)
+          )
+          fields fl;
+        of_builder builder
+    | _ -> raise VariantMismatch
+;;
+
+type my_record  =
+    {
+     a: int;
+     b: string list;
+    }
+ 
+let my_record =
+  let fields =
+    [
+     Field {label = "a"; field_type = Int;
+            get = (fun {a} -> a);
+            set = (fun (r, _) x -> r := Some x)};
+     Field {label = "b"; field_type = List String;
+            get = (fun {b} -> b);
+            set = (fun (_, r) x -> r := Some x)};
+    ]
+  in
+  let create_builder () = (ref None, ref None) in
+  let of_builder (a, b) =
+    match !a, !b with
+    | Some a, Some b -> {a; b}
+    | _ -> failwith "Some fields are missing in record of type my_record"
+  in
+  Record {path = "My_module.my_record"; fields; create_builder; of_builder}
+;;
+
+(* Extension to recursive types and polymorphic variants *)
+(* by Jacques Garrigue *)
+
+type noarg = Noarg
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  (* Support for type variables and recursive types *)
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  (* Change the representation of a type *)
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  (* Sum types (both normal sums and polymorphic variants) *)
+  | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+
+and ('a, 'e, 'b) ty_sum =
+    { sum_proj: 'a -> string * 'e ty_dyn option;
+      sum_cases: (string * ('e,'b) ty_case) list;
+      sum_inj: 'c. ('b,'c) ty_sel * 'c -> 'a; }
+
+and 'e ty_dyn =              (* dynamic type *)
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =           (* selector from a list of types *)
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =          (* type a sum case *)
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+type _ ty_env =              (* type variable substitution *)
+  | Enil : unit ty_env
+  | Econs : ('a,'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+;;
+
+(* Comparing selectors *)
+type (_,_) eq = Eq: ('a,'a) eq
+
+let rec eq_sel : type a b c. (a,b) ty_sel -> (a,c) ty_sel -> (b,c) eq option =
+  fun s1 s2 ->
+    match s1, s2 with
+    | Thd, Thd -> Some Eq
+    | Ttl s1, Ttl s2 ->
+        (match eq_sel s1 s2 with None -> None | Some Eq -> Some Eq)
+    | _ -> None
+
+(* Auxiliary function to get the type of a case from its selector *)
+let rec get_case : type a b e.
+  (b, a) ty_sel -> (string * (e,b) ty_case) list -> string * (a, e) ty option =
+  fun sel cases ->
+  match cases with
+  | (name, TCnoarg sel') :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, None
+      end
+  | (name, TCarg (sel', ty)) :: rem ->
+      begin match eq_sel sel sel' with
+      | None -> get_case sel rem
+      | Some Eq -> name, Some ty
+      end
+  | [] -> raise Not_found
+;;
+
+(* Untyped representation of values *)
+type variant =
+  | VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+
+let may_map f = function Some x -> Some (f x) | None -> None
+
+let rec variantize : type a e. e ty_env -> (a,e) ty -> a -> variant =
+  fun e ty v ->
+  match ty with
+  | Int -> VInt v
+  | String -> VString v
+  | List t -> VList (List.map (variantize e t) v)
+  | Option t -> VOption (may_map (variantize e t) v)
+  | Pair (t1, t2) -> VPair (variantize e t1 (fst v), variantize e t2 (snd v))
+  | Rec t -> variantize (Econs (ty, e)) t v
+  | Pop t -> (match e with Econs (_, e') -> variantize e' t v)
+  | Var -> (match e with Econs (t, e') -> variantize e' t v)
+  | Conv (s, proj, inj, t) -> VConv (s, variantize e t (proj v))
+  | Sum ops ->
+      let tag, arg = ops.sum_proj v in
+      VSum (tag, may_map (function Tdyn (ty,arg) -> variantize e ty arg) arg)
+;;
+
+let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t =
+  fun e ty v ->
+  match ty, v with
+  | Int, VInt x -> x
+  | String, VString x -> x
+  | List ty1, VList vl ->
+      List.map (devariantize e ty1) vl
+  | Pair (ty1, ty2), VPair (x1, x2) ->
+      (devariantize e ty1 x1, devariantize e ty2 x2)
+  | Rec t, _ -> devariantize (Econs (ty, e)) t v
+  | Pop t, _ -> (match e with Econs (_, e') -> devariantize e' t v)
+  | Var, _ -> (match e with Econs (t, e') -> devariantize e' t v)
+  | Conv (s, proj, inj, t), VConv (s', v) when s = s' ->
+      inj (devariantize e t v)
+  | Sum ops, VSum (tag, a) ->
+      begin try match List.assoc tag ops.sum_cases, a with
+      | TCarg (sel, t), Some a -> ops.sum_inj (sel, devariantize e t a)
+      | TCnoarg sel, None -> ops.sum_inj (sel, Noarg)
+      | _ -> raise VariantMismatch
+      with Not_found -> raise VariantMismatch
+      end
+  | _ -> raise VariantMismatch
+;;
+
+(* First attempt: represent 1-constructor variants using Conv *)
+let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t);;
+
+let ty a = Rec (wrap_A (Option (Pair (a, Var)))) ;;
+let v = variantize Enil (ty Int);;
+let x = v (`A (Some (1, `A (Some (2, `A None))))) ;;
+
+(* Can also use it to decompose a tuple *)
+
+let triple t1 t2 t3 =
+  Conv ("Triple", (fun (a,b,c) -> (a,(b,c))),
+        (fun (a,(b,c)) -> (a,b,c)), Pair (t1, Pair (t2, t3)))
+
+let v = variantize Enil (triple String Int Int) ("A", 2, 3) ;;
+
+(* Second attempt: introduce a real sum construct *)
+let ty_abc =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  let proj = function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None
+  (* Define inj in advance to be able to write the type annotation easily *)
+  and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c ->
+    [`A of int | `B of string | `C] = function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+  in
+  (* Coherence of sum_inj and sum_cases is checked by the typing *)
+  Sum { sum_proj = proj; sum_inj = inj; sum_cases =
+        [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+          "C", TCnoarg (Ttl (Ttl Thd)) ] }
+;;
+
+let v = variantize Enil ty_abc (`A 3)
+let a = devariantize Enil ty_abc v
+
+(* And an example with recursion... *)
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum {
+       sum_proj = (function
+           `Nil -> "Nil", None
+         | `Cons p -> "Cons", Some (Tdyn (tcons, p)));
+       sum_cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)];
+       sum_inj = fun (type c) ->
+         (function
+         | Thd, Noarg -> `Nil
+         | Ttl Thd, v -> `Cons v
+         : (noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist)
+         (* One can also write the type annotation directly *)
+     })
+
+let v = variantize Enil (ty_list Int) (`Cons (1, `Cons (2, `Nil))) ;;
+
+
+(* Simpler but weaker approach *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: ('a -> string * 'e ty_dyn option) * (string * 'e ty_dyn option -> 'a)
+             -> ('a, 'e) ty
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+let ty_abc : ([`A of int | `B of string | `C],'e) ty =
+  (* Could also use [get_case] for proj, but direct definition is shorter *)
+  Sum (
+  (function
+      `A n -> "A", Some (Tdyn (Int, n))
+    | `B s -> "B", Some (Tdyn (String, s))
+    | `C   -> "C", None),
+  (function
+      "A", Some (Tdyn (Int, n)) -> `A n
+    | "B", Some (Tdyn (String, s)) -> `B s
+    | "C", None -> `C
+    | _ -> invalid_arg "ty_abc"))
+;;
+
+(* Breaks: no way to pattern-match on a full recursive type *)
+let ty_list : type a e. (a,e) ty -> (a vlist,e) ty = fun t ->
+  let targ = Pair (Pop t, Var) in
+  Rec (Sum (
+  (function `Nil -> "Nil", None
+    | `Cons p -> "Cons", Some (Tdyn (targ, p))),
+  (function "Nil", None -> `Nil
+    | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+;;
+
+(* Define Sum using object instead of record for first-class polymorphism *)
+
+type (_,_) ty =
+  | Int: (int,_) ty
+  | String: (string,_) ty
+  | List: ('a,'e) ty -> ('a list, 'e) ty
+  | Option: ('a,'e) ty -> ('a option, 'e) ty
+  | Pair: (('a,'e) ty * ('b,'e) ty) -> ('a * 'b,'e) ty
+  | Var: ('a, 'a -> 'e) ty
+  | Rec: ('a, 'a -> 'e) ty -> ('a,'e) ty
+  | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum: < proj: 'a -> string * 'e ty_dyn option;
+           cases: (string * ('e,'b) ty_case) list;
+           inj: 'c. ('b,'c) ty_sel * 'c -> 'a >
+          -> ('a, 'e) ty
+
+and 'e ty_dyn =
+  | Tdyn : ('a,'e) ty * 'a -> 'e ty_dyn
+
+and (_,_) ty_sel =
+  | Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+
+and (_,_) ty_case =
+  | TCarg : ('b,'a) ty_sel * ('a,'e) ty -> ('e,'b) ty_case
+  | TCnoarg : ('b,noarg) ty_sel -> ('e,'b) ty_case
+;;
+
+let ty_abc : ([`A of int | `B of string | `C] as 'a, 'e) ty =
+  Sum (object
+    method proj = function
+        `A n -> "A", Some (Tdyn (Int, n))
+      | `B s -> "B", Some (Tdyn (String, s))
+      | `C -> "C", None
+    method cases =
+      [ "A", TCarg (Thd, Int); "B", TCarg (Ttl Thd, String);
+        "C", TCnoarg (Ttl (Ttl Thd)) ];
+    method inj : type c.
+        (int -> string -> noarg -> unit, c) ty_sel * c ->
+          [`A of int | `B of string | `C] =
+      function
+        Thd, v -> `A v
+      | Ttl Thd, v -> `B v
+      | Ttl (Ttl Thd), Noarg -> `C
+      | _ -> assert false
+  end)
+
+type 'a vlist = [`Nil | `Cons of 'a * 'a vlist]
+
+let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = fun t ->
+  let tcons = Pair (Pop t, Var) in
+  Rec (Sum (object
+    method proj = function
+        `Nil -> "Nil", None
+      | `Cons p -> "Cons", Some (Tdyn (tcons, p))
+    method cases = ["Nil", TCnoarg Thd; "Cons", TCarg (Ttl Thd, tcons)]
+    method inj : type c.(noarg -> a * a vlist -> unit, c) ty_sel * c -> a vlist
+    = function
+      | Thd, Noarg -> `Nil
+      | Ttl Thd, v -> `Cons v
+  end))
+;;
+
+(*
+type (_,_) ty_assoc =
+  | Anil : (unit,'e) ty_assoc
+  | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc
+
+and (_,_) ty_pvar =
+  | Pnil : ('a,'e) ty_pvar
+  | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar
+  | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar
+*)

diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
new file mode 100644 (file)
index 0000000..72a301c
--- /dev/null
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference
@@ -0,0 +1,176 @@
+
+#                       type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+#                                                                     type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+val variantize : 't ty -> 't -> variant = <fun>
+exception VariantMismatch
+val devariantize : 't ty -> variant -> 't = <fun>
+#                                                   type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : 'a record -> 'a ty
+and 'a record = { path : string; fields : 'a field_ list; }
+and 'a field_ = Field : ('a, 'b) field -> 'a field_
+and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
+#                                                     type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+val variantize : 't ty -> 't -> variant = <fun>
+#                                                                                                   type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : ('a, 'builder) record -> 'a ty
+and ('a, 'builder) record = {
+  path : string;
+  fields : ('a, 'builder) field list;
+  create_builder : unit -> 'builder;
+  of_builder : 'builder -> 'a;
+}
+and ('a, 'builder) field =
+    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+and ('a, 'builder, 'b) field_ = {
+  label : string;
+  field_type : 'b ty;
+  get : 'a -> 'b;
+  set : 'builder -> 'b -> unit;
+}
+val devariantize : 't ty -> variant -> 't = <fun>
+#                                                   type my_record = { a : int; b : string list; }
+val my_record : my_record ty =
+  Record
+   {path = "My_module.my_record";
+    fields =
+     [Field {label = "a"; field_type = Int; get = <fun>; set = <fun>};
+      Field {label = "b"; field_type = List String; get = <fun>; set = <fun>}];
+    create_builder = <fun>; of_builder = <fun>}
+#                                                                         type noarg = Noarg
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+and ('a, 'e, 'b) ty_sum = {
+  sum_proj : 'a -> string * 'e ty_dyn option;
+  sum_cases : (string * ('e, 'b) ty_case) list;
+  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+}
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+#         type _ ty_env =
+    Enil : unit ty_env
+  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+#                                                         type (_, _) eq = Eq : ('a, 'a) eq
+val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = <fun>
+val get_case :
+  ('b, 'a) ty_sel ->
+  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = <fun>
+#                                                         type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+val may_map : ('a -> 'b) -> 'a option -> 'b option = <fun>
+val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = <fun>
+#                                               val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = <fun>
+#     val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = <fun>
+#   val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
+  <fun>
+# val v : ([ `A of (int * 'a) option ] as 'a) -> variant = <fun>
+# val x : variant =
+  VConv ("`A",
+   VOption
+    (Some
+      (VPair (VInt 1,
+        VConv ("`A",
+         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
+#               val triple :
+  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = <fun>
+val v : variant =
+  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
+#                                       val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
+  Sum
+   {sum_proj = <fun>;
+    sum_cases =
+     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
+      ("C", TCnoarg (Ttl (Ttl Thd)))];
+    sum_inj = <fun>}
+#                                             val a : [ `A of int | `B of string | `C ] = `A 3
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
+val v : variant =
+  VSum ("Cons",
+   Some
+    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
+#                                                               type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a -> string * 'e ty_dyn option) *
+      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>)
+#                   Characters 327-344:
+      | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+                                           ^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type a * a vlist
+       but a pattern was expected which matches values of type
+         ex#46 = ex#47 * ex#48
+#                                                         type (_, _) ty =
+    Int : (int, 'd) ty
+  | String : (string, 'f) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum :
+      < cases : (string * ('e, 'b) ty_case) list;
+        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+#                                                                     val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum <obj>
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
+#   * * * * * * * * *   

diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
new file mode 100644 (file)
index 0000000..72a301c
--- /dev/null
+++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference
@@ -0,0 +1,176 @@
+
+#                       type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+#                                                                     type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+val variantize : 't ty -> 't -> variant = <fun>
+exception VariantMismatch
+val devariantize : 't ty -> variant -> 't = <fun>
+#                                                   type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : 'a record -> 'a ty
+and 'a record = { path : string; fields : 'a field_ list; }
+and 'a field_ = Field : ('a, 'b) field -> 'a field_
+and ('a, 'b) field = { label : string; field_type : 'b ty; get : 'a -> 'b; }
+#                                                     type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VPair of variant * variant
+  | VRecord of (string * variant) list
+val variantize : 't ty -> 't -> variant = <fun>
+#                                                                                                   type 'a ty =
+    Int : int ty
+  | String : string ty
+  | List : 'a ty -> 'a list ty
+  | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+  | Record : ('a, 'builder) record -> 'a ty
+and ('a, 'builder) record = {
+  path : string;
+  fields : ('a, 'builder) field list;
+  create_builder : unit -> 'builder;
+  of_builder : 'builder -> 'a;
+}
+and ('a, 'builder) field =
+    Field : ('a, 'builder, 'b) field_ -> ('a, 'builder) field
+and ('a, 'builder, 'b) field_ = {
+  label : string;
+  field_type : 'b ty;
+  get : 'a -> 'b;
+  set : 'builder -> 'b -> unit;
+}
+val devariantize : 't ty -> variant -> 't = <fun>
+#                                                   type my_record = { a : int; b : string list; }
+val my_record : my_record ty =
+  Record
+   {path = "My_module.my_record";
+    fields =
+     [Field {label = "a"; field_type = Int; get = <fun>; set = <fun>};
+      Field {label = "b"; field_type = List String; get = <fun>; set = <fun>}];
+    create_builder = <fun>; of_builder = <fun>}
+#                                                                         type noarg = Noarg
+type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a, 'e, 'b) ty_sum -> ('a, 'e) ty
+and ('a, 'e, 'b) ty_sum = {
+  sum_proj : 'a -> string * 'e ty_dyn option;
+  sum_cases : (string * ('e, 'b) ty_case) list;
+  sum_inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+}
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+#         type _ ty_env =
+    Enil : unit ty_env
+  | Econs : ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env
+#                                                         type (_, _) eq = Eq : ('a, 'a) eq
+val eq_sel : ('a, 'b) ty_sel -> ('a, 'c) ty_sel -> ('b, 'c) eq option = <fun>
+val get_case :
+  ('b, 'a) ty_sel ->
+  (string * ('e, 'b) ty_case) list -> string * ('a, 'e) ty option = <fun>
+#                                                         type variant =
+    VInt of int
+  | VString of string
+  | VList of variant list
+  | VOption of variant option
+  | VPair of variant * variant
+  | VConv of string * variant
+  | VSum of string * variant option
+val may_map : ('a -> 'b) -> 'a option -> 'b option = <fun>
+val variantize : 'e ty_env -> ('a, 'e) ty -> 'a -> variant = <fun>
+#                                               val devariantize : 'e ty_env -> ('t, 'e) ty -> variant -> 't = <fun>
+#     val wrap_A : ('a, 'b) ty -> ([ `A of 'a ], 'b) ty = <fun>
+#   val ty : ('a, ([ `A of ('a * 'b) option ] as 'b) -> 'c) ty -> ('b, 'c) ty =
+  <fun>
+# val v : ([ `A of (int * 'a) option ] as 'a) -> variant = <fun>
+# val x : variant =
+  VConv ("`A",
+   VOption
+    (Some
+      (VPair (VInt 1,
+        VConv ("`A",
+         VOption (Some (VPair (VInt 2, VConv ("`A", VOption None)))))))))
+#               val triple :
+  ('a, 'b) ty -> ('c, 'b) ty -> ('d, 'b) ty -> ('a * 'c * 'd, 'b) ty = <fun>
+val v : variant =
+  VConv ("Triple", VPair (VString "A", VPair (VInt 2, VInt 3)))
+#                                       val ty_abc : ([ `A of int | `B of string | `C ], 'a) ty =
+  Sum
+   {sum_proj = <fun>;
+    sum_cases =
+     [("A", TCarg (Thd, Int)); ("B", TCarg (Ttl Thd, String));
+      ("C", TCnoarg (Ttl (Ttl Thd)))];
+    sum_inj = <fun>}
+#                                             val a : [ `A of int | `B of string | `C ] = `A 3
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
+val v : variant =
+  VSum ("Cons",
+   Some
+    (VPair (VInt 1, VSum ("Cons", Some (VPair (VInt 2, VSum ("Nil", None)))))))
+#                                                               type (_, _) ty =
+    Int : (int, 'c) ty
+  | String : (string, 'd) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum : ('a -> string * 'e ty_dyn option) *
+      (string * 'e ty_dyn option -> 'a) -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>)
+#                   Characters 327-344:
+      | "Cons", Some (Tdyn (Pair (_, Var), (p : a * a vlist))) -> `Cons p)))
+                                           ^^^^^^^^^^^^^^^^^
+Error: This pattern matches values of type a * a vlist
+       but a pattern was expected which matches values of type
+         ex#46 = ex#47 * ex#48
+#                                                         type (_, _) ty =
+    Int : (int, 'd) ty
+  | String : (string, 'f) ty
+  | List : ('a, 'e) ty -> ('a list, 'e) ty
+  | Option : ('a, 'e) ty -> ('a option, 'e) ty
+  | Pair : (('a, 'e) ty * ('b, 'e) ty) -> ('a * 'b, 'e) ty
+  | Var : ('a, 'a -> 'e) ty
+  | Rec : ('a, 'a -> 'e) ty -> ('a, 'e) ty
+  | Pop : ('a, 'e) ty -> ('a, 'b -> 'e) ty
+  | Conv : string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty
+  | Sum :
+      < cases : (string * ('e, 'b) ty_case) list;
+        inj : 'c. ('b, 'c) ty_sel * 'c -> 'a;
+        proj : 'a -> string * 'e ty_dyn option > -> ('a, 'e) ty
+and 'e ty_dyn = Tdyn : ('a, 'e) ty * 'a -> 'e ty_dyn
+and (_, _) ty_sel =
+    Thd : ('a -> 'b, 'a) ty_sel
+  | Ttl : ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel
+and (_, _) ty_case =
+    TCarg : ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case
+  | TCnoarg : ('b, noarg) ty_sel -> ('e, 'b) ty_case
+#                                                                     val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum <obj>
+type 'a vlist = [ `Cons of 'a * 'a vlist | `Nil ]
+val ty_list : ('a, 'e) ty -> ('a vlist, 'e) ty = <fun>
+#   * * * * * * * * *   

diff --git a/testsuite/tests/typing-gadts/omega07.ml b/testsuite/tests/typing-gadts/omega07.ml
new file mode 100644 (file)
index 0000000..cddfe46
--- /dev/null
+++ b/testsuite/tests/typing-gadts/omega07.ml
@@ -0,0 +1,779 @@
+(*
+   An attempt at encoding omega examples from the 2nd Central European
+   Functional Programming School:
+     Generic Programming in Omega, by Tim Sheard and Nathan Linger
+          http://web.cecs.pdx.edu/~sheard/
+*)
+
+(* Basic types *)
+
+type ('a,'b) sum = Inl of 'a | Inr of 'b
+
+type zero = Zero
+type _ succ
+type _ nat =
+  | NZ : zero nat
+  | NS : 'a nat -> 'a succ nat
+;;
+
+(* 2: A simple example *)
+
+type (_,_) seq =
+  | Snil  : ('a,zero) seq
+  | Scons : 'a * ('a,'n) seq -> ('a, 'n succ) seq
+;;
+
+let l1 = Scons (3, Scons (5, Snil)) ;;
+
+(* We do not have type level functions, so we need to use witnesses. *)
+(* We copy here the definitions from section 3.9 *)
+(* Note the addition of the ['a nat] argument to PlusZ, since we do not
+   have kinds *)
+type (_,_,_) plus =
+  | PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a,'b,'c) plus -> ('a succ, 'b, 'c succ) plus
+;;
+
+let rec length : type a n. (a,n) seq -> n nat = function
+  | Snil -> NZ
+  | Scons (_, s) -> NS (length s)
+;;
+
+(* app returns the catenated lists with a witness proving that
+   the size is the sum of its two inputs *)
+type (_,_,_) app = App : ('a,'p) seq * ('n,'m,'p) plus -> ('a,'n,'m) app
+
+let rec app : type a n m. (a,n) seq -> (a,m) seq -> (a,n,m) app =
+  fun xs ys ->
+  match xs with
+  | Snil -> App (ys, PlusZ (length ys))
+  | Scons (x, xs') ->
+      match app xs' ys with
+      | App (xs'', pl) -> App (Scons (x, xs''), PlusS pl)
+;;
+(* Note: it would be nice to be able to handle existentials in
+   let definitions *)
+
+(* 3.1 Feature: kinds *)
+
+(* We do not have kinds, but we can encode them as predicates *)
+
+type tp
+type nd
+type (_,_) fk
+type _ shape =
+  | Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a,'b) fk shape
+;;
+type tt
+type ff
+type _ boolean =
+  | BT : tt boolean
+  | BF : ff boolean
+;;
+
+(* 3.3 Feature : GADTs *)
+
+type (_,_) path =
+  | Pnone : 'a -> (tp,'a) path
+  | Phere : (nd,'a) path
+  | Pleft : ('x,'a) path -> (('x,'y) fk, 'a) path
+  | Pright : ('y,'a) path -> (('x,'y) fk, 'a) path
+;;
+type (_,_) tree =
+  | Ttip  : (tp,'a) tree
+  | Tnode : 'a -> (nd,'a) tree
+  | Tfork : ('x,'a) tree * ('y,'a) tree -> (('x,'y)fk, 'a) tree
+;;
+let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+;;
+let rec find : type sh.
+    ('a -> 'a -> bool) -> 'a -> (sh,'a) tree -> (sh,'a) path list
+  = fun eq n t ->
+    match t with
+    | Ttip -> []
+    | Tnode m ->
+        if eq n m then [Phere] else []
+    | Tfork (x, y) ->
+        List.map (fun x -> Pleft x) (find eq n x) @
+        List.map (fun x -> Pright x) (find eq n y)
+;;
+let rec extract : type sh. (sh,'a) path -> (sh,'a) tree -> 'a = fun p t ->
+  match (p, t) with
+  | Pnone x, Ttip -> x
+  | Phere, Tnode y -> y
+  | Pleft p, Tfork(l,_) -> extract p l
+  | Pright p, Tfork(_,r) -> extract p r
+;;
+
+(* 3.4 Pattern : Witness *)
+
+type (_,_) le =
+  | LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+;;
+type _ even =
+  | EvenZ : zero even
+  | EvenSS : 'n even -> 'n succ succ even
+;;
+type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+;;
+let even0 : zero even = EvenZ
+let even2 : two even = EvenSS EvenZ
+let even4 : four even = EvenSS (EvenSS EvenZ)
+;;
+let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+;;
+let rec summandLessThanSum : type a b c. (a,b,c) plus -> (a,c) le = fun p ->
+  match p with
+  | PlusZ n -> LeZ n
+  | PlusS p' -> LeS (summandLessThanSum p')
+;;
+
+(* 3.8 Pattern: Leibniz Equality *)
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let convert : type a b. (a,b) equal -> a -> b = fun Eq x -> x
+
+let rec sameNat : type a b. a nat -> b nat -> (a,b) equal option = fun a b ->
+  match a, b with
+  | NZ, NZ -> Some Eq
+  | NS a', NS b' ->
+      begin match sameNat a' b' with
+      | Some Eq -> Some Eq
+      | None -> None
+      end
+  | _ -> None
+;;
+
+(* 3.9 Computing Programs and Properties Simultaneously *)
+
+(* Plus and app1 are moved to section 2 *)
+
+let smaller : type a b. (a succ, b succ) le -> (a,b) le =
+  function LeS x -> x ;;
+
+type (_,_) diff = Diff : 'c nat * ('a,'c,'b) plus -> ('a,'b) diff ;;
+
+(*
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b, le with
+  | NZ, m, _ -> Diff (m, PlusZ m)
+  | NS x, NZ, _ -> assert false
+  | NS x, NS y, q ->
+      match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+*)
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match le, a, b with
+  | LeZ _, _, m -> Diff (m, PlusZ m)
+  | LeS q, NS x, NS y ->
+      match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff =
+  fun le a b ->
+  match a, b,le with (* warning *)
+  | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+  | NS x, NS y, LeS q ->
+      match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+let rec diff : type a b. (a,b) le -> b nat -> (a,b) diff =
+  fun le b ->
+  match b,le with
+  | m, LeZ _ -> Diff (m, PlusZ m)
+  | NS y, LeS q ->
+      match diff q y with Diff (m, p) -> Diff (m, PlusS p)
+;;
+
+type (_,_) filter = Filter : ('m,'n) le * ('a,'m) seq -> ('a,'n) filter
+
+let rec leS' : type m n. (m,n) le -> (m,n succ) le = function
+  | LeZ n -> LeZ (NS n)
+  | LeS le -> LeS (leS' le)
+;;
+
+let rec filter : type a n. (a -> bool) -> (a,n) seq -> (a,n) filter =
+  fun f s ->
+  match s with
+  | Snil -> Filter (LeZ NZ, Snil)
+  | Scons (a,l) ->
+      match filter f l with Filter (le, l') ->
+        if f a then Filter (LeS le, Scons (a, l'))
+        else Filter (leS' le, l')
+;;
+
+(* 4.1 AVL trees *)
+
+type (_,_,_) balance =
+  | Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+
+type _ avl =
+  | Leaf : zero avl
+  | Node :
+      ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ avl
+
+type avl' = Avl : 'h avl -> avl'
+;;
+
+let empty = Avl Leaf
+
+let rec elem : type h. int -> h avl -> bool = fun x t ->
+  match t with
+  | Leaf -> false
+  | Node (_, l, y, r) ->
+      x = y || if x < y then elem x l else elem x r
+;;
+
+let rec rotr : type n. (n succ succ) avl -> int -> n avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL y tR ->
+  match tL with
+  | Node (Same, a, x, b) -> Inr (Node (Less, a, x, Node (More, b, y, tR)))
+  | Node (More, a, x, b) -> Inl (Node (Same, a, x, Node (Same, b, y, tR)))
+  | Node (Less, a, x, Node (Same, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (Less, b, z, c)) ->
+      Inl (Node (Same, Node (More, a, x, b), z, Node (Same, c, y, tR)))
+  | Node (Less, a, x, Node (More, b, z, c)) ->
+      Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
+;;
+let rec rotl : type n. n avl -> int -> (n succ succ) avl ->
+  ((n succ succ) avl, (n succ succ succ) avl) sum =
+  fun tL u tR ->
+  match tR with
+  | Node (Same, a, x, b) -> Inr (Node (More, Node (Less, tL, u, a), x, b))
+  | Node (Less, a, x, b) -> Inl (Node (Same, Node (Same, tL, u, a), x, b))
+  | Node (More, Node (Same, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (Less, a, x, b), y, c) ->
+      Inl (Node (Same, Node (More, tL, u, a), x, Node (Same, b, y, c)))
+  | Node (More, Node (More, a, x, b), y, c) ->
+      Inl (Node (Same, Node (Same, tL, u, a), x, Node (Less, b, y, c)))
+;;
+let rec ins : type n. int -> n avl -> (n avl, (n succ) avl) sum =
+  fun x t ->
+  match t with
+  | Leaf -> Inr (Node (Same, Leaf, x, Leaf))
+  | Node (bal, a, y, b) ->
+      if x = y then Inl t else
+      if x < y then begin
+        match ins x a with
+        | Inl a -> Inl (Node (bal, a, y, b))
+        | Inr a ->
+            match bal with
+            | Less -> Inl (Node (Same, a, y, b))
+            | Same -> Inr (Node (More, a, y, b))
+            | More -> rotr a y b
+      end else begin
+        match ins x b with
+        | Inl b -> Inl (Node (bal, a, y, b) : n avl)
+        | Inr b ->
+            match bal with
+            | More -> Inl (Node (Same, a, y, b) : n avl)
+            | Same -> Inr (Node (Less, a, y, b) : n succ avl)
+            | Less -> rotl a y b
+      end
+;;
+
+let insert x (Avl t) =
+  match ins x t with
+  | Inl t -> Avl t
+  | Inr t -> Avl t
+;;
+
+let rec del_min : type n. (n succ) avl -> int * (n avl, (n succ) avl) sum =
+  function
+  | Node (Less, Leaf, x, r) -> (x, Inl r)
+  | Node (Same, Leaf, x, r) -> (x, Inl r)
+  | Node (bal, (Node _ as l) , x, r) ->
+      match del_min l with
+      | y, Inr l -> (y, Inr (Node (bal, l, x, r)))
+      | y, Inl l ->
+          (y, match bal with
+          | Same -> Inr (Node (Less, l, x, r))
+          | More -> Inl (Node (Same, l, x, r))
+          | Less -> rotl l x r)
+
+type _ avl_del =
+  | Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+
+let rec del : type n. int -> n avl -> n avl_del = fun y t ->
+  match t with
+  | Leaf -> Dsame Leaf
+  | Node (bal, l, x, r) ->
+      if x = y then begin
+        match r with
+        | Leaf ->
+            begin match bal with
+            | Same -> Ddecr (Eq, l)
+            | More -> Ddecr (Eq, l)
+            end
+        | Node _ ->
+            begin match bal, del_min r with
+            | _, (z, Inr r) -> Dsame (Node (bal, l, z, r))
+            | Same, (z, Inl r) -> Dsame (Node (More, l, z, r))
+            | Less, (z, Inl r) -> Ddecr (Eq, Node (Same, l, z, r))
+            | More, (z, Inl r) ->
+                match rotr l z r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else if y < x then begin
+        match del y l with
+        | Dsame l -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,l) ->
+            begin match bal with
+            | Same -> Dsame (Node (Less, l, x, r))
+            | More -> Ddecr (Eq, Node (Same, l, x, r))
+            | Less ->
+                match rotl l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end else begin
+        match del y r with
+        | Dsame r -> Dsame (Node (bal, l, x, r))
+        | Ddecr(Eq,r) ->
+            begin match bal with
+            | Same -> Dsame (Node (More, l, x, r))
+            | Less -> Ddecr (Eq, Node (Same, l, x, r))
+            | More ->
+                match rotr l x r with
+                | Inl t -> Ddecr (Eq, t)
+                | Inr t -> Dsame t
+            end
+      end
+;;
+
+let delete x (Avl t) =
+  match del x t with
+  | Dsame t -> Avl t
+  | Ddecr (_, t) -> Avl t
+;;
+
+
+(* Exercise 22: Red-black trees *)
+
+type red
+type black
+type (_,_) sub_tree =
+  | Bleaf : (black, zero) sub_tree
+  | Rnode :
+      (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode :
+      ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+;;
+
+type dir = LeftD | RightD
+
+type (_,_) ctxt =
+  | CNil : (black,'n) ctxt
+  | CRed : int * dir * (black,'n) sub_tree * (red,'n) ctxt -> (black,'n) ctxt
+  | CBlk : int * dir * ('c1,'n) sub_tree * (black, 'n succ) ctxt -> ('c,'n) ctxt
+;;
+
+let blacken = function
+    Rnode (l, e, r) -> Bnode (l, e, r)
+
+type _ crep =
+  | Red : red crep
+  | Black : black crep
+
+let color : type c n. (c,n) sub_tree -> c crep = function
+  | Bleaf -> Black
+  | Rnode _ -> Red
+  | Bnode _ -> Black
+;;
+
+let rec fill : type c n. (c,n) ctxt -> (c,n) sub_tree -> rb_tree =
+  fun ct t ->
+  match ct with
+  | CNil -> Root t
+  | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t))
+  | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle))
+  | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t))
+  | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle))
+;;
+let recolor d1 pE sib d2 gE uncle t =
+  match d1, d2 with
+  | LeftD, RightD -> Rnode (Bnode (sib, pE, t), gE, uncle)
+  | RightD, RightD -> Rnode (Bnode (t, pE, sib), gE, uncle)
+  | LeftD, LeftD -> Rnode (uncle, gE, Bnode (sib, pE, t))
+  | RightD, LeftD -> Rnode (uncle, gE, Bnode (t, pE, sib))
+;;
+let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) =
+  match d1, d2 with
+  | RightD, RightD -> Bnode (Rnode (x,e,y), pE, Rnode (sib, gE, uncle))
+  | LeftD,  RightD -> Bnode (Rnode (sib, pE, x), e, Rnode (y, gE, uncle))
+  | LeftD,  LeftD  -> Bnode (Rnode (uncle, gE, sib), pE, Rnode (x,e,y))
+  | RightD, LeftD  -> Bnode (Rnode (uncle, gE, x), e, Rnode (y, pE, sib))
+;;
+let rec repair : type c n. (red,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun t ct ->
+  match ct with
+  | CNil -> Root (blacken t)
+  | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t))
+  | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib))
+  | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) ->
+      match color uncle with
+      | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct
+      | Black -> fill ct (rotate dir e sib dir' e' uncle t)
+;;
+let rec ins : type c n. int -> (c,n) sub_tree -> (c,n) ctxt -> rb_tree =
+  fun e t ct ->
+  match t with
+  | Rnode (l, e', r) ->
+      if e < e' then ins e l (CRed (e', RightD, r, ct))
+                else ins e r (CRed (e', LeftD, l, ct))
+  | Bnode (l, e', r) ->
+      if e < e' then ins e l (CBlk (e', RightD, r, ct))
+                else ins e r (CBlk (e', LeftD, l, ct))
+  | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct
+;;
+let insert e (Root t) = ins e t CNil
+;;
+
+(* 5.7 typed object languages using GADTs *)
+
+type _ term =
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let ex1 = Ap (Add, Pair (Const 3, Const 5))
+let ex2 = Pair (ex1, Const 1)
+
+let rec eval_term : type a. a term -> a = function
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x<y
+  | Ap(f,x) -> eval_term f (eval_term x)
+  | Pair(x,y) -> (eval_term x, eval_term y)
+
+type _ rep =
+  | Rint  : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun  : 'a rep * 'b rep -> ('a -> 'b) rep
+
+type (_,_) equal = Eq : ('a,'a) equal
+
+let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option =
+  fun ra rb ->
+  match ra, rb with
+  | Rint, Rint -> Some Eq
+  | Rbool, Rbool -> Some Eq
+  | Rpair (a1, a2), Rpair (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | Rfun (a1, a2), Rfun (b1, b2) ->
+      begin match rep_equal a1 b1 with
+      | None -> None
+      | Some Eq -> match rep_equal a2 b2 with
+        | None -> None
+        | Some Eq -> Some Eq
+      end
+  | _ -> None
+;;
+
+type assoc = Assoc : string * 'a rep * 'a -> assoc
+
+let rec assoc : type a. string -> a rep -> assoc list -> a =
+  fun x r -> function
+  | [] -> raise Not_found
+  | Assoc (x', r', v) :: env ->
+      if x = x' then
+        match rep_equal r r' with
+        | None -> failwith ("Wrong type for " ^ x)
+        | Some Eq -> v
+      else assoc x r env
+
+type _ term =
+  | Var   : string * 'a rep -> 'a term
+  | Abs   : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add   : (int * int -> int) term
+  | LT    : (int * int -> bool) term
+  | Ap    : ('a -> 'b) term * 'a term -> 'b term
+  | Pair  : 'a term * 'b term -> ('a * 'b) term
+
+let rec eval_term : type a. assoc list -> a term -> a =
+  fun env -> function
+  | Var (x, r) -> assoc x r env
+  | Abs (x, r, e) -> fun v -> eval_term (Assoc (x, r, v) :: env) e
+  | Const x -> x
+  | Add -> fun (x,y) -> x+y
+  | LT  -> fun (x,y) -> x<y
+  | Ap(f,x) -> eval_term env f (eval_term env x)
+  | Pair(x,y) -> (eval_term env x, eval_term env y)
+;;
+
+let ex3 = Abs ("x", Rint, Ap (Add, Pair (Var("x",Rint), Var("x",Rint))))
+let ex4 = Ap (ex3, Const 3)
+
+let v4 = eval_term [] ex4
+;;
+
+(* 5.9/5.10 Language with binding *)
+
+type rnil
+type (_,_,_) rcons
+
+type _ is_row =
+  | Rnil  : rnil is_row
+  | Rcons : 'c is_row -> ('a,'b,'c) rcons is_row
+
+type (_,_) lam =
+  | Const : int -> ('e, int) lam
+  | Var : 'a -> (('a,'t,'e) rcons, 't) lam
+  | Shift : ('e,'t) lam -> (('a,'q,'e) rcons, 't) lam
+  | Abs : 'a * (('a,'s,'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+
+type x = X
+type y = Y
+
+let ex1 = App (Var X, Shift (Var Y))
+let ex2 = Abs (X, Abs (Y, App (Shift (Var X), Var Y)))
+;;
+
+type _ env =
+  | Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+
+let rec eval_lam : type e t. e env -> (e, t) lam -> t =
+  fun env m ->
+  match env, m with
+  | _, Const n -> n
+  | Econs (_, v, r), Var _ -> v
+  | Econs (_, _, r), Shift e -> eval_lam r e
+  | _, Abs (n, body) -> fun x -> eval_lam (Econs (n, x, env)) body
+  | _, App (f, x)    -> eval_lam env f (eval_lam env x)
+;;
+
+type add = Add
+type suc = Suc
+
+let env0 = Econs (Zero, 0, Econs (Suc, succ, Econs (Add, (+), Enil)))
+
+let _0 : (_, int) lam = Var Zero
+let suc x = App (Shift (Var Suc : (_, int -> int) lam), x)
+let _1 = suc _0
+let _2 = suc _1
+let _3 = suc _2
+let add = Shift (Shift (Var Add : (_, int -> int -> int) lam))
+
+let double = Abs (X, App (App (Shift add, Var X), Var X))
+let ex3 = App (double, _3)
+;;
+
+let v3 = eval_lam env0 ex3
+;;
+
+(* 5.13: Constructing typing derivations at runtime *)
+
+(* Modified slightly to use the language of 5.10, since this is more fun.
+   Of course this works also with the language of 5.12. *)
+
+type _ rep =
+  | I : int rep
+  | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+
+let rec compare : type a b. a rep -> b rep -> (string, (a,b) equal) sum =
+  fun a b ->
+  match a, b with
+  | I, I -> Inr Eq
+  | Ar(x,y), Ar(s,t) ->
+      begin match compare x s with
+      | Inl _ as e -> e
+      | Inr Eq -> match compare y t with
+        | Inl _ as e -> e
+        | Inr Eq as e -> e
+      end
+  | I, Ar _ -> Inl "I <> Ar _"
+  | Ar _, I -> Inl "Ar _ <> I"
+;;
+
+type term =
+  | C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+
+type _ ctx =
+  | Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t,'x,'e) rcons ctx
+;;
+
+type _ checked =
+  | Cerror of string
+  | Cok : ('e,'t) lam * 't rep -> 'e checked
+
+let rec lookup : type e. string -> e ctx -> e checked =
+  fun name ctx ->
+  match ctx with
+  | Cnil -> Cerror ("Name not found: " ^ name)
+  | Ccons (l,s,t,rs) ->
+      if s = name then Cok (Var l,t) else
+      match lookup name rs with
+      | Cerror m -> Cerror m
+      | Cok (v, t) -> Cok (Shift v, t)
+;;
+
+let rec tc : type n e. n nat -> e ctx -> term -> e checked =
+  fun n ctx t ->
+  match t with
+  | V s -> lookup s ctx
+  | Ap(f,x) ->
+      begin match tc n ctx f with
+      | Cerror _ as e -> e
+      | Cok (f', ft) -> match tc n ctx x with
+        | Cerror _ as e -> e
+        | Cok (x', xt) ->
+            match ft with
+            | Ar (a, b) ->
+                begin match compare a xt with
+                | Inl s -> Cerror s
+                | Inr Eq -> Cok (App (f',x'), b)
+                end
+            | _ -> Cerror "Non fun in Ap"
+      end
+  | Ab(s,t,body) ->
+      begin match tc (NS n) (Ccons (n, s, t, ctx)) body with
+      | Cerror _ as e -> e
+      | Cok (body', et) -> Cok (Abs (n, body'), Ar (t, et))
+      end
+  | C m -> Cok (Const m, I)
+;;
+
+let ctx0 =
+  Ccons (Zero, "0", I,
+         Ccons (Suc, "S", Ar(I,I),
+                Ccons (Add, "+", Ar(I,Ar(I,I)), Cnil)))
+
+let ex1 = Ab ("x", I, Ap(Ap(V"+",V"x"),V"x"));;
+let c1 = tc NZ ctx0 ex1;;
+let ex2 = Ap (ex1, C 3);;
+let c2 = tc NZ ctx0 ex2;;
+
+let eval_checked env = function
+  | Cerror s -> failwith s
+  | Cok (e, I) -> (eval_lam env e : int)
+  | Cok _ -> failwith "Can only evaluate expressions of type I"
+;;
+
+let v2 = eval_checked env0 c2 ;;
+
+(* 5.12 Soundness *)
+
+type pexp
+type pval
+type _ mode =
+  | Pexp : pexp mode
+  | Pval : pval mode
+
+type (_,_) tarr
+type tint
+
+type (_,_) rel =
+  | IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+
+type (_,_,_) lam =
+  | Const : ('a,'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a,'t,'e) rcons, 't) lam
+  | Shift : ('m,'e,'t) lam -> ('m, ('a,'q,'e) rcons, 't) lam
+  | Lam : 'a * ('m, ('a,'s,'e) rcons, 't) lam -> (pval, 'e, ('s,'t) tarr) lam
+  | App : ('m1, 'e, ('s,'t) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+;;
+
+let ex1 = App (Lam (X, Var X), Const (IntR, 3))
+
+let rec mode : type m e t. (m,e,t) lam -> m mode = function
+  | Lam (v, body) -> Pval
+  | Var v -> Pval
+  | Const (r, v) -> Pval
+  | Shift e -> mode e
+  | App _ -> Pexp
+;;
+
+type (_,_) sub =
+  | Id : ('r,'r) sub
+  | Bind : 't * ('m,'r2,'x) lam * ('r,'r2) sub -> (('t,'x,'r) rcons, 'r2) sub
+  | Push : ('r1,'r2) sub -> (('a,'b,'r1) rcons, ('a,'b,'r2) rcons) sub
+
+type (_,_) lam' = Ex : ('m, 's, 't) lam -> ('s,'t) lam'
+;;
+
+let rec subst : type m1 r t s. (m1,r,t) lam -> (r,s) sub -> (s,t) lam' =
+  fun t s ->
+  match t, s with
+  | _, Id -> Ex t
+  | Const(r,c), sub -> Ex (Const (r,c))
+  | Var v, Bind (x, e, r) -> Ex e
+  | Var v, Push sub -> Ex (Var v)
+  | Shift e, Bind (_, _, r) -> subst e r
+  | Shift e, Push sub ->
+      (match subst e sub with Ex a -> Ex (Shift a))
+  | App(f,x), sub ->
+      (match subst f sub, subst x sub with Ex g, Ex y -> Ex (App (g,y)))
+  | Lam(v,x), sub ->
+      (match subst x (Push sub) with Ex body -> Ex (Lam (v, body)))
+;;
+
+type closed = rnil
+
+type 'a rlam = ((pexp,closed,'a) lam, (pval,closed,'a) lam) sum ;;
+
+let rec rule : type a b.
+  (pval, closed, (a,b) tarr) lam -> (pval, closed, a) lam -> b rlam =
+  fun v1 v2 ->
+  match v1, v2 with
+  | Lam(x,body), v ->
+      begin
+        match subst body (Bind (x, v, Id)) with Ex term ->
+        match mode term with
+        | Pexp -> Inl term
+        | Pval -> Inr term
+      end
+  | Const (IntTo b, f), Const (IntR, x) ->
+      Inr (Const (b, f x))
+;;
+let rec onestep : type m t. (m,closed,t) lam -> t rlam = function
+  | Lam (v, body) -> Inr (Lam (v, body))
+  | Const (r, v)  -> Inr (Const (r, v))
+  | App (e1, e2) ->
+      match mode e1, mode e2 with
+      | Pexp, _->
+          begin match onestep e1 with
+          | Inl e -> Inl(App(e,e2))
+          | Inr v -> Inl(App(v,e2))
+          end
+      | Pval, Pexp ->
+          begin match onestep e2 with
+          | Inl e -> Inl(App(e1,e))
+          | Inr v -> Inl(App(e1,v))
+          end
+      | Pval, Pval -> rule e1 e2
+;;

diff --git a/testsuite/tests/typing-gadts/omega07.ml.principal.reference b/testsuite/tests/typing-gadts/omega07.ml.principal.reference
new file mode 100644 (file)
index 0000000..cf8b0b5
--- /dev/null
+++ b/testsuite/tests/typing-gadts/omega07.ml.principal.reference
@@ -0,0 +1,306 @@
+
+# * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
+type zero = Zero
+type _ succ
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+#             type (_, _) seq =
+    Snil : ('a, zero) seq
+  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
+#   val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
+#       *         type (_, _, _) plus =
+    PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+#         val length : ('a, 'n) seq -> 'n nat = <fun>
+#   *                     type (_, _, _) app =
+    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
+val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
+# *                           type tp
+type nd
+type (_, _) fk
+type _ shape =
+    Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
+#           type tt
+type ff
+type _ boolean = BT : tt boolean | BF : ff boolean
+#                 type (_, _) path =
+    Pnone : 'a -> (tp, 'a) path
+  | Phere : (nd, 'a) path
+  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
+  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
+#         type (_, _) tree =
+    Ttip : (tp, 'a) tree
+  | Tnode : 'a -> (nd, 'a) tree
+  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
+#   val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
+  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+#                     val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
+  <fun>
+#             val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = <fun>
+#             type (_, _) le =
+    LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+#       type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
+#         type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+#       val even0 : zero even = EvenZ
+val even2 : two even = EvenSS EvenZ
+val even4 : four even = EvenSS (EvenSS EvenZ)
+#   val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+#         val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = <fun>
+#                                 type (_, _) equal = Eq : ('a, 'a) equal
+val convert : ('a, 'b) equal -> 'a -> 'b = <fun>
+val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun>
+#             val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun>
+#   type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
+#   * * * * * * * * *                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
+#               Characters 87-243:
+  ..match a, b,le with (* warning *)
+    | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+    | NS x, NS y, LeS q ->
+        match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(NS _, NZ, _)
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
+#               val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = <fun>
+#             type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
+val leS' : ('m, 'n) le -> ('m, 'n succ) le = <fun>
+#                   val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = <fun>
+#                             type (_, _, _) balance =
+    Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+type _ avl =
+    Leaf : zero avl
+  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
+      'hR avl -> 'hMax succ avl
+type avl' = Avl : 'h avl -> avl'
+#                 val empty : avl' = Avl Leaf
+val elem : int -> 'h avl -> bool = <fun>
+#                           val rotr :
+  'n succ succ avl ->
+  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun>
+#                         val rotl :
+  'n avl ->
+  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
+  <fun>
+#                                               val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = <fun>
+#           val insert : int -> avl' -> avl' = <fun>
+#                                                                                                                                 val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = <fun>
+type _ avl_del =
+    Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+val del : int -> 'n avl -> 'n avl_del = <fun>
+#           val delete : int -> avl' -> avl' = <fun>
+#                             type red
+type black
+type (_, _) sub_tree =
+    Bleaf : (black, zero) sub_tree
+  | Rnode : (black, 'n) sub_tree * int *
+      (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode : ('cL, 'n) sub_tree * int *
+      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+#               type dir = LeftD | RightD
+type (_, _) ctxt =
+    CNil : (black, 'n) ctxt
+  | CRed : int * dir * (black, 'n) sub_tree *
+      (red, 'n) ctxt -> (black, 'n) ctxt
+  | CBlk : int * dir * ('c1, 'n) sub_tree *
+      (black, 'n succ) ctxt -> ('c, 'n) ctxt
+#                         val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun>
+type _ crep = Red : red crep | Black : black crep
+val color : ('c, 'n) sub_tree -> 'c crep = <fun>
+#                   val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = <fun>
+#             val recolor :
+  dir ->
+  int ->
+  ('a, 'b) sub_tree ->
+  dir ->
+  int ->
+  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
+  <fun>
+#             val rotate :
+  dir ->
+  int ->
+  (black, 'a) sub_tree ->
+  dir ->
+  int ->
+  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
+  <fun>
+#                     val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
+#                     val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
+#   val insert : int -> rb_tree -> rb_tree = <fun>
+#                                                                                                 type _ term =
+    Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
+val ex2 : (int * int) term =
+  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
+val eval_term : 'a term -> 'a = <fun>
+type _ rep =
+    Rint : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
+type (_, _) equal = Eq : ('a, 'a) equal
+val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = <fun>
+#                                                               type assoc = Assoc : string * 'a rep * 'a -> assoc
+val assoc : string -> 'a rep -> assoc list -> 'a = <fun>
+type _ term =
+    Var : string * 'a rep -> 'a term
+  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val eval_term : assoc list -> 'a term -> 'a = <fun>
+#           val ex3 : (int -> int) term =
+  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
+val ex4 : int term =
+  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
+   Const 3)
+val v4 : int = 6
+#                                             type rnil
+type (_, _, _) rcons
+type _ is_row =
+    Rnil : rnil is_row
+  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
+type (_, _) lam =
+    Const : int -> ('e, int) lam
+  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
+  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
+  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+type x = X
+type y = Y
+val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
+  App (Var X, Shift (Var Y))
+val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
+  Abs (<poly>, Abs (<poly>, App (Shift (Var <poly>), Var <poly>)))
+#                           type _ env =
+    Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+val eval_lam : 'e env -> ('e, 't) lam -> 't = <fun>
+#                               type add = Add
+type suc = Suc
+val env0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons env = Econs (Zero, 0, Econs (Suc, <fun>, Econs (Add, <fun>, Enil)))
+val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
+val suc :
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = <fun>
+val _1 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam = App (Shift (Var Suc), Var Zero)
+val _2 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
+val _3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App (Shift (Var Suc),
+   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
+val add :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int -> int)
+  lam = Shift (Shift (Var Add))
+val double :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int)
+  lam =
+  Abs (<poly>,
+   App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>))
+val ex3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App
+   (Abs (<poly>,
+     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+   App (Shift (Var Suc),
+    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
+#     val v3 : int = 6
+#       *                                       type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = <fun>
+#                     type term =
+    C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+type _ ctx =
+    Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
+#                             type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
+val lookup : string -> 'e ctx -> 'e checked = <fun>
+#                                                   val tc : 'n nat -> 'e ctx -> term -> 'e checked = <fun>
+#             val ctx0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons ctx =
+  Ccons (Zero, "0", I,
+   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
+val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
+# val c1 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (Abs (<poly>,
+     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+   Ar (I, I))
+# val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
+# val c2 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (App
+     (Abs (<poly>,
+       App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+     Const 3),
+   I)
+#           val eval_checked : 'a env -> 'a checked -> int = <fun>
+#   val v2 : int = 6
+#                                             type pexp
+type pval
+type _ mode = Pexp : pexp mode | Pval : pval mode
+type (_, _) tarr
+type tint
+type (_, _) rel =
+    IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+type (_, _, _) lam =
+    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
+  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
+  | Lam : 'a *
+      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
+  | App : ('m1, 'e, ('s, 't) tarr) lam *
+      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+#                   val ex1 : (pexp, 'a, tint) lam =
+  App (Lam (<poly>, Var <poly>), Const (IntR, <poly>))
+val mode : ('m, 'e, 't) lam -> 'm mode = <fun>
+#               type (_, _) sub =
+    Id : ('r, 'r) sub
+  | Bind : 't * ('m, 'r2, 'x) lam *
+      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
+  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
+type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
+#                               val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = <fun>
+#       type closed = rnil
+type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
+#                             val rule :
+  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
+  <fun>
+#                                 val onestep : ('m, closed, 't) lam -> 't rlam = <fun>
+# 

diff --git a/testsuite/tests/typing-gadts/omega07.ml.reference b/testsuite/tests/typing-gadts/omega07.ml.reference
new file mode 100644 (file)
index 0000000..cf8b0b5
--- /dev/null
+++ b/testsuite/tests/typing-gadts/omega07.ml.reference
@@ -0,0 +1,306 @@
+
+# * * * * *                       type ('a, 'b) sum = Inl of 'a | Inr of 'b
+type zero = Zero
+type _ succ
+type _ nat = NZ : zero nat | NS : 'a nat -> 'a succ nat
+#             type (_, _) seq =
+    Snil : ('a, zero) seq
+  | Scons : 'a * ('a, 'n) seq -> ('a, 'n succ) seq
+#   val l1 : (int, zero succ succ) seq = Scons (3, Scons (5, Snil))
+#       *         type (_, _, _) plus =
+    PlusZ : 'a nat -> (zero, 'a, 'a) plus
+  | PlusS : ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus
+#         val length : ('a, 'n) seq -> 'n nat = <fun>
+#   *                     type (_, _, _) app =
+    App : ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app
+val app : ('a, 'n) seq -> ('a, 'm) seq -> ('a, 'n, 'm) app = <fun>
+# *                           type tp
+type nd
+type (_, _) fk
+type _ shape =
+    Tp : tp shape
+  | Nd : nd shape
+  | Fk : 'a shape * 'b shape -> ('a, 'b) fk shape
+#           type tt
+type ff
+type _ boolean = BT : tt boolean | BF : ff boolean
+#                 type (_, _) path =
+    Pnone : 'a -> (tp, 'a) path
+  | Phere : (nd, 'a) path
+  | Pleft : ('x, 'a) path -> (('x, 'y) fk, 'a) path
+  | Pright : ('y, 'a) path -> (('x, 'y) fk, 'a) path
+#         type (_, _) tree =
+    Ttip : (tp, 'a) tree
+  | Tnode : 'a -> (nd, 'a) tree
+  | Tfork : ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree
+#   val tree1 : (((tp, nd) fk, (nd, nd) fk) fk, int) tree =
+  Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
+#                     val find : ('a -> 'a -> bool) -> 'a -> ('sh, 'a) tree -> ('sh, 'a) path list =
+  <fun>
+#             val extract : ('sh, 'a) path -> ('sh, 'a) tree -> 'a = <fun>
+#             type (_, _) le =
+    LeZ : 'a nat -> (zero, 'a) le
+  | LeS : ('n, 'm) le -> ('n succ, 'm succ) le
+#       type _ even = EvenZ : zero even | EvenSS : 'n even -> 'n succ succ even
+#         type one = zero succ
+type two = one succ
+type three = two succ
+type four = three succ
+#       val even0 : zero even = EvenZ
+val even2 : two even = EvenSS EvenZ
+val even4 : four even = EvenSS (EvenSS EvenZ)
+#   val p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ)))
+#         val summandLessThanSum : ('a, 'b, 'c) plus -> ('a, 'c) le = <fun>
+#                                 type (_, _) equal = Eq : ('a, 'a) equal
+val convert : ('a, 'b) equal -> 'a -> 'b = <fun>
+val sameNat : 'a nat -> 'b nat -> ('a, 'b) equal option = <fun>
+#             val smaller : ('a succ, 'b succ) le -> ('a, 'b) le = <fun>
+#   type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff
+#   * * * * * * * * *                 val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
+#               Characters 87-243:
+  ..match a, b,le with (* warning *)
+    | NZ, m, LeZ _ -> Diff (m, PlusZ m)
+    | NS x, NS y, LeS q ->
+        match diff q x y with Diff (m, p) -> Diff (m, PlusS p)
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(NS _, NZ, _)
+val diff : ('a, 'b) le -> 'a nat -> 'b nat -> ('a, 'b) diff = <fun>
+#               val diff : ('a, 'b) le -> 'b nat -> ('a, 'b) diff = <fun>
+#             type (_, _) filter = Filter : ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter
+val leS' : ('m, 'n) le -> ('m, 'n succ) le = <fun>
+#                   val filter : ('a -> bool) -> ('a, 'n) seq -> ('a, 'n) filter = <fun>
+#                             type (_, _, _) balance =
+    Less : ('h, 'h succ, 'h succ) balance
+  | Same : ('h, 'h, 'h) balance
+  | More : ('h succ, 'h, 'h succ) balance
+type _ avl =
+    Leaf : zero avl
+  | Node : ('hL, 'hR, 'hMax) balance * 'hL avl * int *
+      'hR avl -> 'hMax succ avl
+type avl' = Avl : 'h avl -> avl'
+#                 val empty : avl' = Avl Leaf
+val elem : int -> 'h avl -> bool = <fun>
+#                           val rotr :
+  'n succ succ avl ->
+  int -> 'n avl -> ('n succ succ avl, 'n succ succ succ avl) sum = <fun>
+#                         val rotl :
+  'n avl ->
+  int -> 'n succ succ avl -> ('n succ succ avl, 'n succ succ succ avl) sum =
+  <fun>
+#                                               val ins : int -> 'n avl -> ('n avl, 'n succ avl) sum = <fun>
+#           val insert : int -> avl' -> avl' = <fun>
+#                                                                                                                                 val del_min : 'n succ avl -> int * ('n avl, 'n succ avl) sum = <fun>
+type _ avl_del =
+    Dsame : 'n avl -> 'n avl_del
+  | Ddecr : ('m succ, 'n) equal * 'm avl -> 'n avl_del
+val del : int -> 'n avl -> 'n avl_del = <fun>
+#           val delete : int -> avl' -> avl' = <fun>
+#                             type red
+type black
+type (_, _) sub_tree =
+    Bleaf : (black, zero) sub_tree
+  | Rnode : (black, 'n) sub_tree * int *
+      (black, 'n) sub_tree -> (red, 'n) sub_tree
+  | Bnode : ('cL, 'n) sub_tree * int *
+      ('cR, 'n) sub_tree -> (black, 'n succ) sub_tree
+type rb_tree = Root : (black, 'n) sub_tree -> rb_tree
+#               type dir = LeftD | RightD
+type (_, _) ctxt =
+    CNil : (black, 'n) ctxt
+  | CRed : int * dir * (black, 'n) sub_tree *
+      (red, 'n) ctxt -> (black, 'n) ctxt
+  | CBlk : int * dir * ('c1, 'n) sub_tree *
+      (black, 'n succ) ctxt -> ('c, 'n) ctxt
+#                         val blacken : (red, 'a) sub_tree -> (black, 'a succ) sub_tree = <fun>
+type _ crep = Red : red crep | Black : black crep
+val color : ('c, 'n) sub_tree -> 'c crep = <fun>
+#                   val fill : ('c, 'n) ctxt -> ('c, 'n) sub_tree -> rb_tree = <fun>
+#             val recolor :
+  dir ->
+  int ->
+  ('a, 'b) sub_tree ->
+  dir ->
+  int ->
+  (black, 'b succ) sub_tree -> ('c, 'b) sub_tree -> (red, 'b succ) sub_tree =
+  <fun>
+#             val rotate :
+  dir ->
+  int ->
+  (black, 'a) sub_tree ->
+  dir ->
+  int ->
+  (black, 'a) sub_tree -> (red, 'a) sub_tree -> (black, 'a succ) sub_tree =
+  <fun>
+#                     val repair : (red, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
+#                     val ins : int -> ('c, 'n) sub_tree -> ('c, 'n) ctxt -> rb_tree = <fun>
+#   val insert : int -> rb_tree -> rb_tree = <fun>
+#                                                                                                 type _ term =
+    Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val ex1 : int term = Ap (Add, Pair (Const 3, Const 5))
+val ex2 : (int * int) term =
+  Pair (Ap (Add, Pair (Const 3, Const 5)), Const 1)
+val eval_term : 'a term -> 'a = <fun>
+type _ rep =
+    Rint : int rep
+  | Rbool : bool rep
+  | Rpair : 'a rep * 'b rep -> ('a * 'b) rep
+  | Rfun : 'a rep * 'b rep -> ('a -> 'b) rep
+type (_, _) equal = Eq : ('a, 'a) equal
+val rep_equal : 'a rep -> 'b rep -> ('a, 'b) equal option = <fun>
+#                                                               type assoc = Assoc : string * 'a rep * 'a -> assoc
+val assoc : string -> 'a rep -> assoc list -> 'a = <fun>
+type _ term =
+    Var : string * 'a rep -> 'a term
+  | Abs : string * 'a rep * 'b term -> ('a -> 'b) term
+  | Const : int -> int term
+  | Add : (int * int -> int) term
+  | LT : (int * int -> bool) term
+  | Ap : ('a -> 'b) term * 'a term -> 'b term
+  | Pair : 'a term * 'b term -> ('a * 'b) term
+val eval_term : assoc list -> 'a term -> 'a = <fun>
+#           val ex3 : (int -> int) term =
+  Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint))))
+val ex4 : int term =
+  Ap (Abs ("x", Rint, Ap (Add, Pair (Var ("x", Rint), Var ("x", Rint)))),
+   Const 3)
+val v4 : int = 6
+#                                             type rnil
+type (_, _, _) rcons
+type _ is_row =
+    Rnil : rnil is_row
+  | Rcons : 'c is_row -> ('a, 'b, 'c) rcons is_row
+type (_, _) lam =
+    Const : int -> ('e, int) lam
+  | Var : 'a -> (('a, 't, 'e) rcons, 't) lam
+  | Shift : ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam
+  | Abs : 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam
+  | App : ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam
+type x = X
+type y = Y
+val ex1 : ((x, 'a -> 'b, (y, 'a, 'c) rcons) rcons, 'b) lam =
+  App (Var X, Shift (Var Y))
+val ex2 : ('a, ('b -> 'c) -> 'b -> 'c) lam =
+  Abs (<poly>, Abs (<poly>, App (Shift (Var <poly>), Var <poly>)))
+#                           type _ env =
+    Enil : rnil env
+  | Econs : 'a * 't * 'e env -> ('a, 't, 'e) rcons env
+val eval_lam : 'e env -> ('e, 't) lam -> 't = <fun>
+#                               type add = Add
+type suc = Suc
+val env0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons env = Econs (Zero, 0, Econs (Suc, <fun>, Econs (Add, <fun>, Enil)))
+val _0 : ((zero, int, 'a) rcons, int) lam = Var Zero
+val suc :
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam ->
+  (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = <fun>
+val _1 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam = App (Shift (Var Suc), Var Zero)
+val _2 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))
+val _3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App (Shift (Var Suc),
+   App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)))
+val add :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int -> int)
+  lam = Shift (Shift (Var Add))
+val double :
+  (('a, 'b, ('c, 'd, (add, int -> int -> int, 'e) rcons) rcons) rcons,
+   int -> int)
+  lam =
+  Abs (<poly>,
+   App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>))
+val ex3 :
+  ((zero, int, (suc, int -> int, (add, int -> int -> int, '_a) rcons) rcons)
+   rcons, int)
+  lam =
+  App
+   (Abs (<poly>,
+     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+   App (Shift (Var Suc),
+    App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))))
+#     val v3 : int = 6
+#       *                                       type _ rep = I : int rep | Ar : 'a rep * 'b rep -> ('a -> 'b) rep
+val compare : 'a rep -> 'b rep -> (string, ('a, 'b) equal) sum = <fun>
+#                     type term =
+    C of int
+  | Ab : string * 'a rep * term -> term
+  | Ap of term * term
+  | V of string
+type _ ctx =
+    Cnil : rnil ctx
+  | Ccons : 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx
+#                             type _ checked = Cerror of string | Cok : ('e, 't) lam * 't rep -> 'e checked
+val lookup : string -> 'e ctx -> 'e checked = <fun>
+#                                                   val tc : 'n nat -> 'e ctx -> term -> 'e checked = <fun>
+#             val ctx0 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons ctx =
+  Ccons (Zero, "0", I,
+   Ccons (Suc, "S", Ar (I, I), Ccons (Add, "+", Ar (I, Ar (I, I)), Cnil)))
+val ex1 : term = Ab ("x", I, Ap (Ap (V "+", V "x"), V "x"))
+# val c1 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (Abs (<poly>,
+     App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+   Ar (I, I))
+# val ex2 : term = Ap (Ab ("x", I, Ap (Ap (V "+", V "x"), V "x")), C 3)
+# val c2 :
+  (zero, int, (suc, int -> int, (add, int -> int -> int, rnil) rcons) rcons)
+  rcons checked =
+  Cok
+   (App
+     (Abs (<poly>,
+       App (App (Shift (Shift (Shift (Var Add))), Var <poly>), Var <poly>)),
+     Const 3),
+   I)
+#           val eval_checked : 'a env -> 'a checked -> int = <fun>
+#   val v2 : int = 6
+#                                             type pexp
+type pval
+type _ mode = Pexp : pexp mode | Pval : pval mode
+type (_, _) tarr
+type tint
+type (_, _) rel =
+    IntR : (tint, int) rel
+  | IntTo : ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel
+type (_, _, _) lam =
+    Const : ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam
+  | Var : 'a -> (pval, ('a, 't, 'e) rcons, 't) lam
+  | Shift : ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam
+  | Lam : 'a *
+      ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) lam
+  | App : ('m1, 'e, ('s, 't) tarr) lam *
+      ('m2, 'e, 's) lam -> (pexp, 'e, 't) lam
+#                   val ex1 : (pexp, 'a, tint) lam =
+  App (Lam (<poly>, Var <poly>), Const (IntR, <poly>))
+val mode : ('m, 'e, 't) lam -> 'm mode = <fun>
+#               type (_, _) sub =
+    Id : ('r, 'r) sub
+  | Bind : 't * ('m, 'r2, 'x) lam *
+      ('r, 'r2) sub -> (('t, 'x, 'r) rcons, 'r2) sub
+  | Push : ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub
+type (_, _) lam' = Ex : ('m, 's, 't) lam -> ('s, 't) lam'
+#                               val subst : ('m1, 'r, 't) lam -> ('r, 's) sub -> ('s, 't) lam' = <fun>
+#       type closed = rnil
+type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
+#                             val rule :
+  (pval, closed, ('a, 'b) tarr) lam -> (pval, closed, 'a) lam -> 'b rlam =
+  <fun>
+#                                 val onestep : ('m, closed, 't) lam -> 't rlam = <fun>
+# 

diff --git a/testsuite/tests/typing-gadts/pr5332.ml b/testsuite/tests/typing-gadts/pr5332.ml
new file mode 100644 (file)
index 0000000..ef70e5a
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5332.ml
@@ -0,0 +1,17 @@
+type ('env, 'a) var =
+ | Zero : ('a * 'env, 'a) var
+ | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+;;
+type ('env, 'a) typ =
+ | Tint : ('env, int) typ
+ | Tbool : ('env, bool) typ
+ | Tvar : ('env, 'a) var -> ('env, 'a) typ
+;;
+let f : type env a. (env, a) typ -> (env, a) typ -> int = fun ta tb ->
+ match ta, tb with
+   | Tint, Tint -> 0
+   | Tbool, Tbool -> 1
+   | Tvar var, tb -> 2
+;;
+let x = f Tint (Tvar Zero)
+;;

diff --git a/testsuite/tests/typing-gadts/pr5332.ml.reference b/testsuite/tests/typing-gadts/pr5332.ml.reference
new file mode 100644 (file)
index 0000000..4cf48a2
--- /dev/null
+++ b/testsuite/tests/typing-gadts/pr5332.ml.reference
@@ -0,0 +1,19 @@
+
+#       type ('env, 'a) var =
+    Zero : ('a * 'env, 'a) var
+  | Succ : ('env, 'a) var -> ('b * 'env, 'a) var
+#         type ('env, 'a) typ =
+    Tint : ('env, int) typ
+  | Tbool : ('env, bool) typ
+  | Tvar : ('env, 'a) var -> ('env, 'a) typ
+#           Characters 72-156:
+  .match ta, tb with
+     | Tint, Tint -> 0
+     | Tbool, Tbool -> 1
+     | Tvar var, tb -> 2
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Tbool, Tvar _)
+val f : ('env, 'a) typ -> ('env, 'a) typ -> int = <fun>
+#   Exception: Match_failure ("//toplevel//", 9, 1).
+# 

diff --git a/testsuite/tests/typing-gadts/term-conv.ml b/testsuite/tests/typing-gadts/term-conv.ml
new file mode 100644 (file)
index 0000000..9b53cd6
--- /dev/null
+++ b/testsuite/tests/typing-gadts/term-conv.ml
@@ -0,0 +1,139 @@
+(* HOAS to de Bruijn, by chak *)
+(* http://www.cse.unsw.edu.au/~chak/haskell/term-conv/ *)
+
+module Typeable = struct
+  type 'a ty =
+    | Int: int ty
+    | String: string ty
+    | List: 'a ty -> 'a list ty
+    | Pair: ('a ty * 'b ty) -> ('a * 'b) ty
+    | Fun: ('a ty * 'b ty) -> ('a -> 'b) ty
+
+  type (_,_) eq = Eq : ('a,'a) eq
+
+  exception CastFailure
+  let rec check_eq : type t t'. t ty -> t' ty -> (t,t') eq = fun t t' ->
+    match t, t' with
+    | Int, Int -> Eq
+    | String, String -> Eq
+    | List t, List t' -> (match check_eq t t' with Eq -> Eq)
+    | Pair (t1,t2), Pair (t1',t2') ->
+        (match check_eq t1 t1', check_eq t2 t2' with Eq, Eq -> Eq)
+    | Fun (t1,t2), Fun (t1',t2') ->
+        (match check_eq t1 t1', check_eq t2 t2' with Eq, Eq -> Eq)
+    | _ -> raise CastFailure
+
+  let gcast : type t t'. t ty -> t' ty -> t -> t' = fun t t' x ->
+    match check_eq t t' with Eq -> x
+end;;
+
+module HOAS = struct
+  open Typeable
+
+  type _ term =
+    | Tag : 't ty * int -> 't term
+    | Con : 't -> 't term
+    | Lam : 's ty * ('s term -> 't term) -> ('s -> 't) term
+    | App : ('s -> 't) term * 's term -> 't term
+
+  let rec intp : type t. t term -> t = function
+    | Tag (_, ix) -> failwith "HOAS.intp"
+    | Con v      -> v
+    | Lam (_, f) -> fun x -> intp (f (Con x))
+    | App (f, a) -> intp f (intp a)
+end;;
+
+module DeBruijn = struct
+  type ('env,'t) ix =
+    | ZeroIx : ('env * 't, 't) ix
+    | SuccIx : ('env,'t) ix -> ('env * 's, 't) ix
+
+  let rec to_int : type env t. (env,t) ix -> int = function
+    | ZeroIx   -> 0
+    | SuccIx n -> to_int n + 1
+
+  type ('env,'t) term =
+    | Var : ('env,'t) ix -> ('env,'t) term
+    | Con : 't -> ('env,'t) term
+    | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+    | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+
+  type _ stack =
+    | Empty : unit stack
+    | Push : 'env stack * 't -> ('env * 't) stack
+
+  let rec prj : type env t. (env,t) ix -> env stack -> t = fun i s ->
+    match i, s with
+    | ZeroIx, Push (s,v) -> v
+    | SuccIx i, Push (s,_) -> prj i s
+
+  let rec intp : type env t. (env,t) term -> env stack -> t = fun t s ->
+    match t with
+    | Var ix -> prj ix s
+    | Con v  -> v
+    | Lam b  -> fun x -> intp b (Push (s, x))
+    | App(f,a) -> intp f s (intp a s)
+end;;
+
+module Convert = struct
+  type (_,_) layout =
+    | EmptyLayout : ('env, unit) layout
+    | PushLayout  :
+        't Typeable.ty * ('env,'env') layout * ('env,'t) DeBruijn.ix
+           -> ('env,'env' * 't) layout
+
+  let rec size : type env env'. (env,env') layout -> int = function
+    | EmptyLayout -> 0
+    | PushLayout (_, lyt, _) -> size lyt + 1
+
+  let rec inc : type env env'. (env,env') layout -> (env * 't, env') layout =
+    function
+      | EmptyLayout -> EmptyLayout
+      | PushLayout (t, lyt, ix) -> PushLayout (t, inc lyt, DeBruijn.SuccIx ix)
+
+  let rec prj : type env env' t.
+        t Typeable.ty -> int -> (env,env') layout -> (env,t) DeBruijn.ix
+    = fun t n -> function
+      | EmptyLayout -> failwith "Convert.prj: internal error"
+      | PushLayout (t', l, ix) ->
+          if n = 0 then
+            match Typeable.check_eq t t' with Typeable.Eq -> ix
+          else prj t (n-1) l
+
+  let rec cvt :
+    type env t. (env,env) layout -> t HOAS.term -> (env,t) DeBruijn.term =
+    fun lyt -> function
+      | HOAS.Tag (t, sz) -> DeBruijn.Var (prj t (size lyt - sz -1) lyt)
+      | HOAS.Con v -> DeBruijn.Con v
+      | HOAS.Lam (t, f) ->
+          let lyt' = PushLayout (t, inc lyt, DeBruijn.ZeroIx) in
+          DeBruijn.Lam (cvt lyt' (f (HOAS.Tag (t, size lyt))))
+      | HOAS.App (f, a) ->
+          DeBruijn.App (cvt lyt f, cvt lyt a)
+
+  let convert t = cvt EmptyLayout t
+end;;
+
+module Main = struct
+  open HOAS
+  let i t = Lam (t, fun x -> x)
+  let zero t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> x))
+  let one t = Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, x)))
+  let two t =
+    Lam (Typeable.Fun(t,t), fun f -> Lam(t, fun x -> App (f, App (f, x))))
+  let three t =
+    Lam (Typeable.Fun(t,t),
+         fun f -> Lam(t, fun x -> App (f, App (f, App (f, x)))))
+  let plus t =
+    let t1 = Typeable.Fun(t,t) in let t2 = Typeable.Fun(t1,t1) in
+    Lam (t2, fun m -> Lam (t2, fun n ->
+      Lam (t1, fun f -> Lam(t, fun x -> App(App(m,f), App(App(n,f),x))))))
+
+  let plus_2_3 t = App (App (plus t, two t), three t)
+
+  open Convert
+
+  let i' = convert (i Typeable.Int)
+  let plus_2_3' = convert (plus_2_3 Typeable.Int)
+  let eval_plus_2_3' = DeBruijn.intp plus_2_3' DeBruijn.Empty succ 0
+end;;

diff --git a/testsuite/tests/typing-gadts/term-conv.ml.principal.reference b/testsuite/tests/typing-gadts/term-conv.ml.principal.reference
new file mode 100644 (file)
index 0000000..cff10f1
--- /dev/null
+++ b/testsuite/tests/typing-gadts/term-conv.ml.principal.reference
@@ -0,0 +1,71 @@
+
+#                                                       module Typeable :
+  sig
+    type 'a ty =
+        Int : int ty
+      | String : string ty
+      | List : 'a ty -> 'a list ty
+      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
+    type (_, _) eq = Eq : ('a, 'a) eq
+    exception CastFailure
+    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
+    val gcast : 't ty -> 't' ty -> 't -> 't'
+  end
+#                               module HOAS :
+  sig
+    type _ term =
+        Tag : 't Typeable.ty * int -> 't term
+      | Con : 't -> 't term
+      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
+      | App : ('s -> 't) term * 's term -> 't term
+    val intp : 't term -> 't
+  end
+#                                                               module DeBruijn :
+  sig
+    type ('env, 't) ix =
+        ZeroIx : ('env * 't, 't) ix
+      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
+    val to_int : ('env, 't) ix -> int
+    type ('env, 't) term =
+        Var : ('env, 't) ix -> ('env, 't) term
+      | Con : 't -> ('env, 't) term
+      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+    type _ stack =
+        Empty : unit stack
+      | Push : 'env stack * 't -> ('env * 't) stack
+    val prj : ('env, 't) ix -> 'env stack -> 't
+    val intp : ('env, 't) term -> 'env stack -> 't
+  end
+#                                                                             module Convert :
+  sig
+    type (_, _) layout =
+        EmptyLayout : ('env, unit) layout
+      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
+          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
+    val size : ('env, 'env') layout -> int
+    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
+    val prj :
+      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
+    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
+    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
+  end
+#                                               module Main :
+  sig
+    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
+    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val plus :
+      'a Typeable.ty ->
+      ((('a -> 'a) -> 'a -> 'a) ->
+       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
+      HOAS.term
+    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val i' : (unit, int -> int) DeBruijn.term
+    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
+    val eval_plus_2_3' : int
+  end
+# 

diff --git a/testsuite/tests/typing-gadts/term-conv.ml.reference b/testsuite/tests/typing-gadts/term-conv.ml.reference
new file mode 100644 (file)
index 0000000..cff10f1
--- /dev/null
+++ b/testsuite/tests/typing-gadts/term-conv.ml.reference
@@ -0,0 +1,71 @@
+
+#                                                       module Typeable :
+  sig
+    type 'a ty =
+        Int : int ty
+      | String : string ty
+      | List : 'a ty -> 'a list ty
+      | Pair : ('a ty * 'b ty) -> ('a * 'b) ty
+      | Fun : ('a ty * 'b ty) -> ('a -> 'b) ty
+    type (_, _) eq = Eq : ('a, 'a) eq
+    exception CastFailure
+    val check_eq : 't ty -> 't' ty -> ('t, 't') eq
+    val gcast : 't ty -> 't' ty -> 't -> 't'
+  end
+#                               module HOAS :
+  sig
+    type _ term =
+        Tag : 't Typeable.ty * int -> 't term
+      | Con : 't -> 't term
+      | Lam : 's Typeable.ty * ('s term -> 't term) -> ('s -> 't) term
+      | App : ('s -> 't) term * 's term -> 't term
+    val intp : 't term -> 't
+  end
+#                                                               module DeBruijn :
+  sig
+    type ('env, 't) ix =
+        ZeroIx : ('env * 't, 't) ix
+      | SuccIx : ('env, 't) ix -> ('env * 's, 't) ix
+    val to_int : ('env, 't) ix -> int
+    type ('env, 't) term =
+        Var : ('env, 't) ix -> ('env, 't) term
+      | Con : 't -> ('env, 't) term
+      | Lam : ('env * 's, 't) term -> ('env, 's -> 't) term
+      | App : ('env, 's -> 't) term * ('env, 's) term -> ('env, 't) term
+    type _ stack =
+        Empty : unit stack
+      | Push : 'env stack * 't -> ('env * 't) stack
+    val prj : ('env, 't) ix -> 'env stack -> 't
+    val intp : ('env, 't) term -> 'env stack -> 't
+  end
+#                                                                             module Convert :
+  sig
+    type (_, _) layout =
+        EmptyLayout : ('env, unit) layout
+      | PushLayout : 't Typeable.ty * ('env, 'env') layout *
+          ('env, 't) DeBruijn.ix -> ('env, 'env' * 't) layout
+    val size : ('env, 'env') layout -> int
+    val inc : ('env, 'env') layout -> ('env * 't, 'env') layout
+    val prj :
+      't Typeable.ty -> int -> ('env, 'env') layout -> ('env, 't) DeBruijn.ix
+    val cvt : ('env, 'env) layout -> 't HOAS.term -> ('env, 't) DeBruijn.term
+    val convert : 'a HOAS.term -> (unit, 'a) DeBruijn.term
+  end
+#                                               module Main :
+  sig
+    val i : 'a Typeable.ty -> ('a -> 'a) HOAS.term
+    val zero : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val one : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val two : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val three : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val plus :
+      'a Typeable.ty ->
+      ((('a -> 'a) -> 'a -> 'a) ->
+       (('a -> 'a) -> 'a -> 'a) -> ('a -> 'a) -> 'a -> 'a)
+      HOAS.term
+    val plus_2_3 : 'a Typeable.ty -> (('a -> 'a) -> 'a -> 'a) HOAS.term
+    val i' : (unit, int -> int) DeBruijn.term
+    val plus_2_3' : (unit, (int -> int) -> int -> int) DeBruijn.term
+    val eval_plus_2_3' : int
+  end
+# 

diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml
new file mode 100644 (file)
index 0000000..3fb5730
--- /dev/null
+++ b/testsuite/tests/typing-gadts/test.ml
@@ -0,0 +1,514 @@
+module Exp = 
+  struct
+
+    type _ t = 
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t 
+
+
+    let rec eval : type s . s t -> s = 
+      function
+       | IntLit x -> x
+       | BoolLit y -> y
+       | Pair (x,y) ->
+            (eval x,eval y)
+       | App (f,a) ->
+           (eval f) (eval a)
+       | Abs f -> f 
+
+    let discern : type a. a t -> _ = function
+        IntLit _ -> 1
+      | BoolLit _ -> 2
+      | Pair _ -> 3
+      | App _ -> 4
+      | Abs _ -> 5
+  end
+;;
+
+module List = 
+  struct
+    type zero
+    type _ t = 
+      | Nil : zero t
+      | Cons : 'a * 'b t -> ('a * 'b) t
+    let head =
+      function
+       | Cons (a,b) -> a
+    let tail =
+      function
+       | Cons (a,b) -> b
+    let rec length : type a . a t -> int = 
+      function
+       | Nil -> 0
+       | Cons (a,b) -> length b
+  end
+;;
+
+module Nonexhaustive = 
+  struct
+    type 'a u = 
+      | C1 : int -> int u 
+      | C2 : bool -> bool u
+           
+    type 'a v = 
+      | C1 : int -> int v
+
+    let unexhaustive : type s . s u -> s = 
+      function
+       | C2 x -> x
+
+
+    module M : sig type t type u end = 
+      struct
+        type t = int
+        type u = bool
+      end          
+    type 'a t = 
+      | Foo : M.t -> M.t t 
+      | Bar : M.u -> M.u t
+    let same_type : type s . s t * s t -> bool  =
+      function
+       | Foo _ , Foo _ -> true
+       | Bar _, Bar _ -> true
+  end
+;;
+
+module Exhaustive = 
+  struct
+    type t = int
+    type u = bool
+    type 'a v = 
+      | Foo : t -> t v 
+      | Bar : u -> u v
+
+    let same_type : type s . s v * s v -> bool  =
+      function
+       | Foo _ , Foo _ -> true
+       | Bar _, Bar _ -> true    
+  end
+;;
+
+module Existential_escape = 
+  struct
+    type _ t = C : int -> int t
+    type u = D : 'a t -> u
+    let eval (D x) = x
+  end
+;;
+
+module Rectype = 
+  struct
+    type (_,_) t = C : ('a,'a) t 
+    let _ = 
+      fun (type s) ->
+       let a : (s, s * s) t = failwith "foo" in 
+       match a with
+         C ->
+           ()
+  end
+;;
+
+module Or_patterns = 
+struct
+      type _ t = 
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+
+    let rec eval : type s . s t -> unit = 
+      function
+       | (IntLit _ | BoolLit _) -> ()
+
+end
+;;
+
+module Polymorphic_variants = 
+  struct
+      type _ t = 
+      | IntLit : int -> int t
+      | BoolLit : bool -> bool t
+
+    let rec eval : type s . [`A] * s t -> unit = 
+      function
+       | `A, IntLit _ -> ()
+       | `A, BoolLit _ -> ()
+  end    
+;;
+
+module Propagation = struct
+  type _ t = 
+      IntLit : int -> int t
+    | BoolLit : bool -> bool t
+
+  let check : type s. s t -> s = function
+    | IntLit n -> n
+    | BoolLit b -> b
+
+  let check : type s. s t -> s = fun x ->
+    let r = match x with
+    | IntLit n -> (n : s )
+    | BoolLit b -> b
+    in r
+end
+;;
+
+module Normal_constrs = struct
+  type a = A
+  type b = B
+
+  let f = function A -> 1 | B -> 2
+end;;
+
+type _ t = Int : int t ;;
+
+let ky x y = ignore (x = y); x ;;
+
+let test : type a. a t -> a =
+  function Int -> ky (1 : a) 1
+;;
+
+let test : type a. a t -> _ =
+  function Int -> 1       (* ok *)
+;;
+
+let test : type a. a t -> _ =
+  function Int -> ky (1 : a) 1  (* fails *)
+;;
+
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> ky (1 : a) 1  (* fails *)
+  in r
+;;
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> ky 1 (1 : a)  (* fails *)
+  in r
+;;
+let test (type a) x =
+  let r = match (x : a t) with Int -> ky 1 1
+  in r
+;;
+let test : type a. a t -> a = fun x ->
+  let r = match x with Int -> (1 : a)       (* ok! *)
+  in r
+;;
+let test : type a. a t -> _ = fun x ->
+  let r = match x with Int -> 1       (* ok! *)
+  in r
+;;
+let test : type a. a t -> a = fun x ->
+  let r : a = match x with Int -> 1
+  in r (* ok *)
+;;
+let test2 : type a. a t -> a option = fun x ->
+  let r = ref None in
+  begin match x with Int -> r := Some (1 : a) end;
+  !r (* ok *)
+;;
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  begin match x with Int -> r := Some 1 end;
+  !r (* ok *)
+;;
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  let u = ref None in
+  begin match x with Int -> r := Some 1; u := !r end;
+  !u
+;; (* ok (u non-ambiguous) *)
+let test2 : type a. a t -> a option = fun x ->
+  let r : a option ref = ref None in
+  let u = ref None in
+  begin match x with Int -> u := Some 1; r := !u end;
+  !u
+;; (* fails because u : (int | a) option ref *)
+let test2 : type a. a t -> a option = fun x ->
+  let u = ref None in
+  let r : a option ref = ref None in
+  begin match x with Int -> r := Some 1; u := !r end;
+  !u
+;; (* ok *)
+let test2 : type a. a t -> a option = fun x ->
+  let u = ref None in
+  let a =
+    let r : a option ref = ref None in
+    begin match x with Int -> r := Some 1; u := !r end;
+    !u
+  in a
+;; (* ok *)
+let either = ky
+let we_y1x (type a) (x : a) (v : a t) =
+  match v with Int -> let y = either 1 x in y
+;; (* fail *)
+
+(* Effect of external consraints *)
+let f (type a) (x : a t) y =
+  ignore (y : a);
+  let r = match x with Int -> (y : a) in (* ok *)
+  r
+;;
+let f (type a) (x : a t) y =
+  let r = match x with Int -> (y : a) in
+  ignore (y : a); (* ok *)
+  r
+;;
+let f (type a) (x : a t) y =
+  ignore (y : a);
+  let r = match x with Int -> y in (* ok *)
+  r
+;;
+let f (type a) (x : a t) y =
+  let r = match x with Int -> y in
+  ignore (y : a); (* ok *)
+  r
+;;
+let f (type a) (x : a t) (y : a) =
+  match x with Int -> y (* returns 'a *)
+;;
+
+(* Combination with local modules *)
+
+let f (type a) (x : a t) y =
+  match x with Int ->
+    let module M = struct type b = a let z = (y : b) end
+    in M.z
+;; (* fails because of aliasing... *)
+
+let f (type a) (x : a t) y =
+  match x with Int ->
+    let module M = struct type b = int let z = (y : b) end
+    in M.z
+;; (* ok *)
+
+(* Objects and variants *)
+
+type _ h =
+  | Has_m : <m : int> h
+  | Has_b : <b : bool> h
+
+let f : type a. a h -> a = function
+  | Has_m -> object method m = 1 end
+  | Has_b -> object method b = true end
+;;
+type _ j =
+  | Has_A : [`A of int] j
+  | Has_B : [`B of bool] j
+
+let f : type a. a j -> a = function
+  | Has_A -> `A 1
+  | Has_B -> `B true
+;;
+
+type (_,_) eq = Eq : ('a,'a) eq ;;
+
+let f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
+  fun Eq o -> o
+;; (* fail *)
+
+let f : type a b. (a,b) eq -> <m : a; ..> -> <m : b; ..> =
+  fun Eq o -> o
+;; (* fail *)
+
+let f (type a) (type b) (eq : (a,b) eq) (o : <m : a; ..>) : <m : b; ..> =
+  match eq with Eq -> o ;; (* should fail *)
+
+let f : type a b. (a,b) eq -> <m : a> -> <m : b> =
+  fun Eq o -> o
+;; (* ok *)
+
+let int_of_bool : (bool,int) eq = Obj.magic Eq;;
+
+let x = object method m = true end;;
+let y = (x, f int_of_bool x);;
+
+let f : type a. (a, int) eq -> <m : a> -> bool =
+  fun Eq o -> ignore (o : <m : int; ..>); o#m = 3
+;; (* should be ok *)
+
+let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
+  fun eq o ->
+    ignore (o : < m : a >);
+    let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
+    r;;
+
+let f : type a b. (a,b) eq -> < m : a; .. > -> < m : b > =
+  fun eq o ->
+    let r : < m : b > = match eq with Eq -> o in (* fail *)
+    ignore (o : < m : a >);
+    r;;
+
+let f : type a b. (a,b) eq -> [> `A of a] -> [> `A of b] =
+  fun Eq o -> o ;; (* fail *)
+
+let f (type a) (type b) (eq : (a,b) eq) (v : [> `A of a]) : [> `A of b] =
+  match eq with Eq -> v ;; (* should fail *)
+
+let f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
+  fun Eq o -> o ;; (* fail *)
+
+let f : type a b. (a,b) eq -> [`A of a | `B] -> [`A of b | `B] =
+  fun Eq o -> o ;; (* ok *)
+
+let f : type a. (a, int) eq -> [`A of a] -> bool =
+  fun Eq v -> match v with `A 1 -> true | _ -> false
+;; (* ok *)
+
+let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
+  fun eq o ->
+    ignore (o : [< `A of a | `B]);
+    let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
+    r;;
+
+let f : type a b. (a,b) eq -> [> `A of a | `B] -> [`A of b | `B] =
+  fun eq o ->
+    let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
+    ignore (o : [< `A of a | `B]);
+    r;;
+
+(* Pattern matching *)
+
+type 'a t =
+    A of int | B of bool | C of float | D of 'a
+
+type _ ty =
+  | TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match x, y with
+  | _, A z -> z
+  | _, B z -> if z then 1 else 2
+  | _, C z -> truncate z
+  | TE TC, D [|1.0|] -> 14
+  | TA, D 0 -> -1
+  | TA, D z -> z
+  | TD "bye", D false -> 13
+  | TD "hello", D true -> 12
+ (* | TB, D z -> if z then 1 else 2 *)
+  | TC, D z -> truncate z
+  | _, D _ -> 0
+;;
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match x, y with
+  | _, A z -> z
+  | _, B z -> if z then 1 else 2
+  | _, C z -> truncate z
+  | TE TC, D [|1.0|] -> 14
+  | TA, D 0 -> -1
+  | TA, D z -> z
+;; (* warn *)
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match y, x with
+  | A z, _ -> z
+  | B z, _ -> if z then 1 else 2
+  | C z, _ -> truncate z
+  | D [|1.0|], TE TC -> 14
+  | D 0, TA -> -1
+  | D z, TA -> z
+;; (* fail *)
+
+type ('a,'b) pair = {right:'a; left:'b}
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match {left=x; right=y} with
+  | {left=_; right=A z} -> z
+  | {left=_; right=B z} -> if z then 1 else 2
+  | {left=_; right=C z} -> truncate z
+  | {left=TE TC; right=D [|1.0|]} -> 14
+  | {left=TA; right=D 0} -> -1
+  | {left=TA; right=D z} -> z
+;; (* fail *)
+
+type ('a,'b) pair = {left:'a; right:'b}
+
+let f : type a. a ty -> a t -> int = fun x y ->
+  match {left=x; right=y} with
+  | {left=_; right=A z} -> z
+  | {left=_; right=B z} -> if z then 1 else 2
+  | {left=_; right=C z} -> truncate z
+  | {left=TE TC; right=D [|1.0|]} -> 14
+  | {left=TA; right=D 0} -> -1
+  | {left=TA; right=D z} -> z
+;; (* ok *)
+
+(* Injectivity *)
+
+module M : sig type 'a t val eq : ('a t, 'b t) eq end =
+  struct type 'a t = int let eq = Eq end
+;;
+
+let f : type a b. (a M.t, b M.t) eq -> (a, b) eq =
+  function Eq -> Eq (* fail *)
+;;
+
+let f : type a b. (a M.t * a, b M.t * b) eq -> (a, b) eq =
+  function Eq -> Eq (* ok *)
+;;
+
+let f : type a b. (a * a M.t, b * b M.t) eq -> (a, b) eq =
+  function Eq -> Eq (* ok *)
+;;
+
+(* Applications of polymorphic variants *)
+
+type _ t =
+  | V1 : [`A | `B] t
+  | V2 : [`C | `D] t
+
+let f : type a. a t -> a = function
+  | V1 -> `A
+  | V2 -> `C
+;;
+
+f V1;;
+
+(* PR#5425 and PR#5427 *)
+
+type _ int_foo =
+  | IF_constr : <foo:int; ..> int_foo
+
+type _ int_bar = 
+  | IB_constr : <bar:int; ..> int_bar
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:<foo:int>)
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:<foo:int;bar:int>)
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  (x:<foo:int;bar:int;..>)
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) : t =
+  let IF_constr, IB_constr = e, e' in
+  (x:<foo:int;bar:int;..>)
+;;
+
+let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) =
+  let IF_constr, IB_constr = e, e' in
+  x, x#foo, x#bar
+;;
+
+(* PR#5554 *)
+
+type 'a ty = Int : int -> int ty;;
+
+let f : type a. a ty -> a =
+  fun x -> match x with Int y -> y;;
+
+let g : type a. a ty -> a =
+  let () = () in
+  fun x -> match x with Int y -> y;;

diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference
new file mode 100644 (file)
index 0000000..3125e1e
--- /dev/null
+++ b/testsuite/tests/typing-gadts/test.ml.principal.reference
@@ -0,0 +1,309 @@
+
+#                                                         module Exp :
+  sig
+    type _ t =
+        IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t
+    val eval : 's t -> 's
+    val discern : 'a t -> int
+  end
+#                                     module List :
+  sig
+    type zero
+    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
+    val head : ('a * 'b) t -> 'a
+    val tail : ('a * 'b) t -> 'b t
+    val length : 'a t -> int
+  end
+#                                                         Characters 206-227:
+  ......function
+       | C2 x -> x
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+C1 _
+Characters 469-526:
+  ......function
+       | Foo _ , Foo _ -> true
+       | Bar _, Bar _ -> true
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Bar _, Foo _)
+module Nonexhaustive :
+  sig
+    type 'a u = C1 : int -> int u | C2 : bool -> bool u
+    type 'a v = C1 : int -> int v
+    val unexhaustive : 's u -> 's
+    module M : sig type t type u end
+    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
+    val same_type : 's t * 's t -> bool
+  end
+#                             module Exhaustive :
+  sig
+    type t = int
+    type u = bool
+    type 'a v = Foo : t -> t v | Bar : u -> u v
+    val same_type : 's v * 's v -> bool
+  end
+#               Characters 119-120:
+      let eval (D x) = x
+                       ^
+Error: This expression has type ex#16 t
+       but an expression was expected of type ex#16 t
+       The type constructor ex#16 would escape its scope
+#                       Characters 157-158:
+         C ->
+     ^
+Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t
+#                         Characters 174-182:
+       | (IntLit _ | BoolLit _) -> ()
+      ^^^^^^^^
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type s t
+#                         Characters 213-226:
+       | `A, BoolLit _ -> ()
+     ^^^^^^^^^^^^^
+Error: This pattern matches values of type ([? `A ] as 'a) * bool t
+       but a pattern was expected which matches values of type 'a * int t
+#                                 Characters 300-301:
+      | BoolLit b -> b
+                     ^
+Error: This expression has type bool but an expression was expected of type s
+#             Characters 87-88:
+    let f = function A -> 1 | B -> 2
+                              ^
+Error: This pattern matches values of type b
+       but a pattern was expected which matches values of type a
+#   type _ t = Int : int t
+#   val ky : 'a -> 'a -> 'a = <fun>
+#       val test : 'a t -> 'a = <fun>
+#       val test : 'a t -> int = <fun>
+#       Characters 49-61:
+    function Int -> ky (1 : a) 1  (* fails *)
+                    ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#         Characters 70-82:
+    let r = match x with Int -> ky (1 : a) 1  (* fails *)
+                                ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#       Characters 69-81:
+    let r = match x with Int -> ky 1 (1 : a)  (* fails *)
+                                ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#       val test : 'a t -> int = <fun>
+#       val test : 'a t -> 'a = <fun>
+#       val test : 'a t -> int = <fun>
+#       val test : 'a t -> 'a = <fun>
+#         val test2 : 'a t -> 'a option = <fun>
+#         val test2 : 'a t -> 'a option = <fun>
+#           val test2 : 'a t -> 'a option = <fun>
+#           Characters 152-154:
+    begin match x with Int -> u := Some 1; r := !u end;
+                                                ^^
+Error: This expression has type int option
+       but an expression was expected of type a option
+       Type int is not compatible with type a = int 
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#           val test2 : 'a t -> 'a option = <fun>
+#               val test2 : 'a t -> 'a option = <fun>
+#       Characters 100-101:
+    match v with Int -> let y = either 1 x in y
+                                              ^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#             val f : 'a t -> 'a -> 'a = <fun>
+#         val f : 'a t -> 'a -> 'a = <fun>
+#         val f : 'a t -> 'a -> 'a = <fun>
+#         val f : 'a t -> 'a -> 'a = <fun>
+#     val f : 'a t -> 'a -> 'a = <fun>
+#               Characters 136-137:
+      let module M = struct type b = a let z = (y : b) end
+                                                ^
+Error: This expression has type a = int
+       but an expression was expected of type b = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#           val f : 'a t -> int -> int = <fun>
+#                     type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
+val f : 'a h -> 'a = <fun>
+#               type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
+val f : 'a j -> 'a = <fun>
+#   type (_, _) eq = Eq : ('a, 'a) eq
+#       Characters 5-91:
+  ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
+    fun Eq o -> o
+Error: The universal type variable 'b cannot be generalized:
+       it is already bound to another variable.
+#       Characters 74-75:
+    fun Eq o -> o
+                ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 97-98:
+    match eq with Eq -> o ;; (* should fail *)
+                        ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#       val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
+#   val int_of_bool : (bool, int) eq = Eq
+#   val x : < m : bool > = <obj>
+# val y : < m : bool > * < m : int > = (<obj>, <obj>)
+#       val f : ('a, int) eq -> < m : 'a > -> bool = <fun>
+#           Characters 146-147:
+      let r : < m : b > = match eq with Eq -> o in (* fail with principal *)
+                                              ^
+Error: This expression has type < m : a >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#           Characters 118-119:
+      let r : < m : b > = match eq with Eq -> o in (* fail *)
+                                              ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 74-75:
+    fun Eq o -> o ;; (* fail *)
+                ^
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 97-98:
+    match eq with Eq -> v ;; (* should fail *)
+                        ^
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 5-85:
+  ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
+    fun Eq o -> o..............
+Error: This definition has type
+         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
+       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
+#     val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
+#       val f : ('a, int) eq -> [ `A of 'a ] -> bool = <fun>
+#           Characters 166-167:
+      let r : [`A of b | `B] = match eq with Eq -> o in (* fail with principal *)
+                                                   ^
+Error: This expression has type [ `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#           Characters 131-132:
+      let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
+                                                   ^
+Error: This expression has type [> `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#                                                     type 'a t = A of int | B of bool | C of float | D of 'a
+type _ ty =
+    TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+val f : 'a ty -> 'a t -> int = <fun>
+#                   Characters 51-202:
+  ..match x, y with
+    | _, A z -> z
+    | _, B z -> if z then 1 else 2
+    | _, C z -> truncate z
+    | TE TC, D [|1.0|] -> 14
+    | TA, D 0 -> -1
+    | TA, D z -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(TE TC, D [|  |])
+val f : 'a ty -> 'a t -> int = <fun>
+#                   Characters 147-154:
+    | D [|1.0|], TE TC -> 14
+        ^^^^^^^
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+#                       Characters 259-266:
+    | {left=TE TC; right=D [|1.0|]} -> 14
+                           ^^^^^^^
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+#                       Characters 92-334:
+  ..match {left=x; right=y} with
+    | {left=_; right=A z} -> z
+    | {left=_; right=B z} -> if z then 1 else 2
+    | {left=_; right=C z} -> truncate z
+    | {left=TE TC; right=D [|1.0|]} -> 14
+    | {left=TA; right=D 0} -> -1
+    | {left=TA; right=D z} -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{left=TE TC; right=D [|  |]}
+type ('a, 'b) pair = { left : 'a; right : 'b; }
+val f : 'a ty -> 'a t -> int = <fun>
+#           module M : sig type 'a t val eq : ('a t, 'b t) eq end
+#       Characters 69-71:
+    function Eq -> Eq (* fail *)
+                   ^^
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, b) eq
+#       val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun>
+#       val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun>
+#                     type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
+val f : 'a t -> 'a = <fun>
+#   - : [ `A | `B ] = `A
+#                 type _ int_foo = IF_constr : < foo : int; .. > int_foo
+type _ int_bar = IB_constr : < bar : int; .. > int_bar
+#         Characters 98-99:
+    (x:<foo:int>)
+     ^
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < foo : int >
+       Type ex#20 = < bar : int; .. > is not compatible with type <  > 
+       The second object type has no method bar
+#         Characters 98-99:
+    (x:<foo:int;bar:int>)
+     ^
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < bar : int; foo : int >
+       Type ex#22 = < bar : int; .. > is not compatible with type
+         < bar : int > 
+#         Characters 98-99:
+    (x:<foo:int;bar:int;..>)
+     ^
+Error: This expression has type < bar : int; foo : int; .. > as 'a
+       but an expression was expected of type 'a
+       The type constructor ex#25 would escape its scope
+#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun>
+#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun>
+#       type 'a ty = Int : int -> int ty
+#     val f : 'a ty -> 'a = <fun>
+#       val g : 'a ty -> 'a = <fun>
+# 

diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference
new file mode 100644 (file)
index 0000000..36401d1
--- /dev/null
+++ b/testsuite/tests/typing-gadts/test.ml.reference
@@ -0,0 +1,296 @@
+
+#                                                         module Exp :
+  sig
+    type _ t =
+        IntLit : int -> int t
+      | BoolLit : bool -> bool t
+      | Pair : 'a t * 'b t -> ('a * 'b) t
+      | App : ('a -> 'b) t * 'a t -> 'b t
+      | Abs : ('a -> 'b) -> ('a -> 'b) t
+    val eval : 's t -> 's
+    val discern : 'a t -> int
+  end
+#                                     module List :
+  sig
+    type zero
+    type _ t = Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t
+    val head : ('a * 'b) t -> 'a
+    val tail : ('a * 'b) t -> 'b t
+    val length : 'a t -> int
+  end
+#                                                         Characters 206-227:
+  ......function
+       | C2 x -> x
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+C1 _
+Characters 469-526:
+  ......function
+       | Foo _ , Foo _ -> true
+       | Bar _, Bar _ -> true
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(Bar _, Foo _)
+module Nonexhaustive :
+  sig
+    type 'a u = C1 : int -> int u | C2 : bool -> bool u
+    type 'a v = C1 : int -> int v
+    val unexhaustive : 's u -> 's
+    module M : sig type t type u end
+    type 'a t = Foo : M.t -> M.t t | Bar : M.u -> M.u t
+    val same_type : 's t * 's t -> bool
+  end
+#                             module Exhaustive :
+  sig
+    type t = int
+    type u = bool
+    type 'a v = Foo : t -> t v | Bar : u -> u v
+    val same_type : 's v * 's v -> bool
+  end
+#               Characters 119-120:
+      let eval (D x) = x
+                       ^
+Error: This expression has type ex#16 t
+       but an expression was expected of type ex#16 t
+       The type constructor ex#16 would escape its scope
+#                       Characters 157-158:
+         C ->
+     ^
+Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t
+#                         Characters 174-182:
+       | (IntLit _ | BoolLit _) -> ()
+      ^^^^^^^^
+Error: This pattern matches values of type int t
+       but a pattern was expected which matches values of type s t
+#                         Characters 213-226:
+       | `A, BoolLit _ -> ()
+     ^^^^^^^^^^^^^
+Error: This pattern matches values of type ([? `A ] as 'a) * bool t
+       but a pattern was expected which matches values of type 'a * int t
+#                                 module Propagation :
+  sig
+    type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+    val check : 's t -> 's
+  end
+#             Characters 87-88:
+    let f = function A -> 1 | B -> 2
+                              ^
+Error: This pattern matches values of type b
+       but a pattern was expected which matches values of type a
+#   type _ t = Int : int t
+#   val ky : 'a -> 'a -> 'a = <fun>
+#       val test : 'a t -> 'a = <fun>
+#       val test : 'a t -> int = <fun>
+#       Characters 49-61:
+    function Int -> ky (1 : a) 1  (* fails *)
+                    ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#         Characters 70-82:
+    let r = match x with Int -> ky (1 : a) 1  (* fails *)
+                                ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#       Characters 69-81:
+    let r = match x with Int -> ky 1 (1 : a)  (* fails *)
+                                ^^^^^^^^^^^^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#       val test : 'a t -> int = <fun>
+#       val test : 'a t -> 'a = <fun>
+#       val test : 'a t -> int = <fun>
+#       val test : 'a t -> 'a = <fun>
+#         val test2 : 'a t -> 'a option = <fun>
+#         val test2 : 'a t -> 'a option = <fun>
+#           val test2 : 'a t -> 'a option = <fun>
+#           Characters 152-154:
+    begin match x with Int -> u := Some 1; r := !u end;
+                                                ^^
+Error: This expression has type int option
+       but an expression was expected of type a option
+       Type int is not compatible with type a = int 
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#           val test2 : 'a t -> 'a option = <fun>
+#               val test2 : 'a t -> 'a option = <fun>
+#       Characters 100-101:
+    match v with Int -> let y = either 1 x in y
+                                              ^
+Error: This expression has type a = int
+       but an expression was expected of type a = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#             val f : 'a t -> 'a -> 'a = <fun>
+#         val f : 'a t -> 'a -> 'a = <fun>
+#         val f : 'a t -> 'a -> 'a = <fun>
+#         val f : 'a t -> 'a -> 'a = <fun>
+#     val f : 'a t -> 'a -> 'a = <fun>
+#               Characters 136-137:
+      let module M = struct type b = a let z = (y : b) end
+                                                ^
+Error: This expression has type a = int
+       but an expression was expected of type b = int
+       This instance of int is ambiguous:
+       it would escape the scope of its equation
+#           val f : 'a t -> int -> int = <fun>
+#                     type _ h = Has_m : < m : int > h | Has_b : < b : bool > h
+val f : 'a h -> 'a = <fun>
+#               type _ j = Has_A : [ `A of int ] j | Has_B : [ `B of bool ] j
+val f : 'a j -> 'a = <fun>
+#   type (_, _) eq = Eq : ('a, 'a) eq
+#       Characters 5-91:
+  ....f : type a b. (a,b) eq -> (<m : a; ..> as 'c) -> (<m : b; ..> as 'c) =
+    fun Eq o -> o
+Error: The universal type variable 'b cannot be generalized:
+       it is already bound to another variable.
+#       Characters 74-75:
+    fun Eq o -> o
+                ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 97-98:
+    match eq with Eq -> o ;; (* should fail *)
+                        ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b; .. >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#       val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
+#   val int_of_bool : (bool, int) eq = Eq
+#   val x : < m : bool > = <obj>
+# val y : < m : bool > * < m : int > = (<obj>, <obj>)
+#       val f : ('a, int) eq -> < m : 'a > -> bool = <fun>
+#           val f : ('a, 'b) eq -> < m : 'a > -> < m : 'b > = <fun>
+#           Characters 118-119:
+      let r : < m : b > = match eq with Eq -> o in (* fail *)
+                                              ^
+Error: This expression has type < m : a; .. >
+       but an expression was expected of type < m : b >
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 74-75:
+    fun Eq o -> o ;; (* fail *)
+                ^
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 97-98:
+    match eq with Eq -> v ;; (* should fail *)
+                        ^
+Error: This expression has type [> `A of a ]
+       but an expression was expected of type [> `A of b ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#     Characters 5-85:
+  ....f : type a b. (a,b) eq -> [< `A of a | `B] -> [< `A of b | `B] =
+    fun Eq o -> o..............
+Error: This definition has type
+         ('a, 'b) eq -> ([< `A of 'b & 'a | `B ] as 'c) -> 'c
+       which is less general than 'a0 'b0. ('a0, 'b0) eq -> 'c -> 'c
+#     val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
+#       val f : ('a, int) eq -> [ `A of 'a ] -> bool = <fun>
+#           val f : ('a, 'b) eq -> [ `A of 'a | `B ] -> [ `A of 'b | `B ] = <fun>
+#           Characters 131-132:
+      let r : [`A of b | `B] = match eq with Eq -> o in (* fail *)
+                                                   ^
+Error: This expression has type [> `A of a | `B ]
+       but an expression was expected of type [ `A of b | `B ]
+       Type a is not compatible with type b = a 
+       This instance of a is ambiguous:
+       it would escape the scope of its equation
+#                                                     type 'a t = A of int | B of bool | C of float | D of 'a
+type _ ty =
+    TE : 'a ty -> 'a array ty
+  | TA : int ty
+  | TB : bool ty
+  | TC : float ty
+  | TD : string -> bool ty
+val f : 'a ty -> 'a t -> int = <fun>
+#                   Characters 51-202:
+  ..match x, y with
+    | _, A z -> z
+    | _, B z -> if z then 1 else 2
+    | _, C z -> truncate z
+    | TE TC, D [|1.0|] -> 14
+    | TA, D 0 -> -1
+    | TA, D z -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(TE TC, D [|  |])
+val f : 'a ty -> 'a t -> int = <fun>
+#                   Characters 147-154:
+    | D [|1.0|], TE TC -> 14
+        ^^^^^^^
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+#                       Characters 259-266:
+    | {left=TE TC; right=D [|1.0|]} -> 14
+                           ^^^^^^^
+Error: This pattern matches values of type 'a array
+       but a pattern was expected which matches values of type a
+#                       Characters 92-334:
+  ..match {left=x; right=y} with
+    | {left=_; right=A z} -> z
+    | {left=_; right=B z} -> if z then 1 else 2
+    | {left=_; right=C z} -> truncate z
+    | {left=TE TC; right=D [|1.0|]} -> 14
+    | {left=TA; right=D 0} -> -1
+    | {left=TA; right=D z} -> z
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{left=TE TC; right=D [|  |]}
+type ('a, 'b) pair = { left : 'a; right : 'b; }
+val f : 'a ty -> 'a t -> int = <fun>
+#           module M : sig type 'a t val eq : ('a t, 'b t) eq end
+#       Characters 69-71:
+    function Eq -> Eq (* fail *)
+                   ^^
+Error: This expression has type (a, a) eq
+       but an expression was expected of type (a, b) eq
+#       val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun>
+#       val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun>
+#                     type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t
+val f : 'a t -> 'a = <fun>
+#   - : [ `A | `B ] = `A
+#                 type _ int_foo = IF_constr : < foo : int; .. > int_foo
+type _ int_bar = IB_constr : < bar : int; .. > int_bar
+#         Characters 98-99:
+    (x:<foo:int>)
+     ^
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < foo : int >
+       Type ex#20 = < bar : int; .. > is not compatible with type <  > 
+       The second object type has no method bar
+#         Characters 98-99:
+    (x:<foo:int;bar:int>)
+     ^
+Error: This expression has type t = < foo : int; .. >
+       but an expression was expected of type < bar : int; foo : int >
+       Type ex#22 = < bar : int; .. > is not compatible with type
+         < bar : int > 
+#         Characters 98-99:
+    (x:<foo:int;bar:int;..>)
+     ^
+Error: This expression has type < bar : int; foo : int; .. > as 'a
+       but an expression was expected of type 'a
+       The type constructor ex#25 would escape its scope
+#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a = <fun>
+#         val g : 'a -> 'a int_foo -> 'a int_bar -> 'a * int * int = <fun>
+#       type 'a ty = Int : int -> int ty
+#     val f : 'a ty -> 'a = <fun>
+#       val g : 'a ty -> 'a = <fun>
+# 

diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml
new file mode 100644 (file)
index 0000000..08708a6
--- /dev/null
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml
@@ -0,0 +1,45 @@
+(* Injectivity *)
+
+type (_, _) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a) (type b) (x : a) ->
+    let module M =
+      (functor (T : sig type 'a t end) ->
+       struct
+         let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+       end)
+        (struct type 'a t = unit end)
+    in M.f Refl
+;;
+
+(* Variance and subtyping *)
+
+type (_, +_) eq = Refl : ('a, 'a) eq
+
+let magic : 'a 'b. 'a -> 'b =
+  fun (type a) (type b) (x : a) ->
+    let bad_proof (type a) =
+      (Refl : (< m : a>, <m : a>) eq :> (<m : a>, < >) eq) in
+    let downcast : type a. (a, < >) eq -> < > -> a =
+      fun (type a) (Refl : (a, < >) eq) (s : < >) -> (s :> a) in
+    (downcast bad_proof ((object method m = x end) :> < >)) # m
+;;
+
+(* Record patterns *)
+
+type _ t =
+  | IntLit : int t
+  | BoolLit : bool t
+
+let check : type s . s t * s -> bool = function
+  | BoolLit, false -> false
+  | IntLit , 6 -> false
+;;
+
+type ('a, 'b) pair = { fst : 'a; snd : 'b }
+
+let check : type s . (s t, s) pair -> bool = function
+  | {fst = BoolLit; snd = false} -> false
+  | {fst = IntLit ; snd =  6} -> false
+;;

diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference
new file mode 100644 (file)
index 0000000..ddae4d2
--- /dev/null
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml.principal.reference
@@ -0,0 +1,29 @@
+
+#                           Characters 240-248:
+           let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+                                              ^^^^^^^^
+Error: Type a is not a subtype of b 
+#                         Characters 36-67:
+  type (_, +_) eq = Refl : ('a, 'a) eq
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this GADT definition, the variance of some parameter
+       cannot be checked
+#                     Characters 115-175:
+  .......................................function
+    | BoolLit, false -> false
+    | IntLit , 6 -> false
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(IntLit, 0)
+type _ t = IntLit : int t | BoolLit : bool t
+val check : 's t * 's -> bool = <fun>
+#             Characters 91-180:
+  .............................................function
+    | {fst = BoolLit; snd = false} -> false
+    | {fst = IntLit ; snd =  6} -> false
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{fst=IntLit; snd=0}
+type ('a, 'b) pair = { fst : 'a; snd : 'b; }
+val check : ('s t, 's) pair -> bool = <fun>
+# 

diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml.reference b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference
new file mode 100644 (file)
index 0000000..ddae4d2
--- /dev/null
+++ b/testsuite/tests/typing-gadts/yallop_bugs.ml.reference
@@ -0,0 +1,29 @@
+
+#                           Characters 240-248:
+           let f (Refl : (a T.t, b T.t) eq) = (x :> b)
+                                              ^^^^^^^^
+Error: Type a is not a subtype of b 
+#                         Characters 36-67:
+  type (_, +_) eq = Refl : ('a, 'a) eq
+       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In this GADT definition, the variance of some parameter
+       cannot be checked
+#                     Characters 115-175:
+  .......................................function
+    | BoolLit, false -> false
+    | IntLit , 6 -> false
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+(IntLit, 0)
+type _ t = IntLit : int t | BoolLit : bool t
+val check : 's t * 's -> bool = <fun>
+#             Characters 91-180:
+  .............................................function
+    | {fst = BoolLit; snd = false} -> false
+    | {fst = IntLit ; snd =  6} -> false
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+{fst=IntLit; snd=0}
+type ('a, 'b) pair = { fst : 'a; snd : 'b; }
+val check : ('s t, 's) pair -> bool = <fun>
+# 

diff --git a/testsuite/tests/typing-implicit_unpack/Makefile b/testsuite/tests/typing-implicit_unpack/Makefile
new file mode 100644 (file)
index 0000000..5f42b70
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+

diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
new file mode 100644 (file)
index 0000000..3910059
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml
@@ -0,0 +1,165 @@
+(*
+   Implicit unpack allows to omit the signature in (val ...) expressions.
+
+   It also adds (module M : S) and (module M) patterns, relying on
+   implicit (val ...) for the implementation. Such patterns can only
+   be used in function definition, match clauses, and let ... in.
+
+   New: implicit pack is also supported, and you only need to be able
+   to infer the the module type path from the context.
+ *)
+(* ocaml -principal *)
+
+(* Use a module pattern *)
+let sort (type s) (module Set : Set.S with type elt = s) l =
+  Set.elements (List.fold_right Set.add l Set.empty)
+
+(* No real improvement here? *)
+let make_set (type s) cmp : (module Set.S with type elt = s) =
+  (module Set.Make (struct type t = s let compare = cmp end))
+
+(* No type annotation here *)
+let sort_cmp (type s) cmp =
+  sort (module Set.Make (struct type t = s let compare = cmp end))
+
+module type S = sig type t val x : t end;;
+let f (module M : S with type t = int) = M.x;;
+let f (module M : S with type t = 'a) = M.x;; (* Error *)
+let f (type a) (module M : S with type t = a) = M.x;;
+f (module struct type t = int let x = 1 end);;
+
+type 'a s = {s: (module S with type t = 'a)};;
+{s=(module struct type t = int let x = 1 end)};;
+let f {s=(module M)} = M.x;; (* Error *)
+let f (type a) ({s=(module M)} : a s) = M.x;;
+
+type s = {s: (module S with type t = int)};;
+let f {s=(module M)} = M.x;;
+let f {s=(module M)} {s=(module N)} = M.x + N.x;;
+
+module type S = sig val x : int end;;
+let f (module M : S) y (module N : S) = M.x + y + N.x;;
+let m = (module struct let x = 3 end);; (* Error *)
+let m = (module struct let x = 3 end : S);;
+f m 1 m;;
+f m 1 (module struct let x = 2 end);;
+
+let (module M) = m in M.x;;
+let (module M) = m;; (* Error: only allowed in [let .. in] *)
+class c = let (module M) = m in object end;; (* Error again *)
+module M = (val m);;
+
+module type S' = sig val f : int -> int end;;
+(* Even works with recursion, but must be fully explicit *)
+let rec (module M : S') =
+  (module struct let f n = if n <= 0 then 1 else n * M.f (n-1) end : S')
+in M.f 3;;
+
+(* Subtyping *)
+
+module type S = sig type t type u val x : t * u end
+let f (l : (module S with type t = int and type u = bool) list) =
+  (l :> (module S with type u = bool) list)
+
+(* GADTs from the manual *)
+(* the only modification is in to_string *)
+
+module TypEq : sig
+  type ('a, 'b) t
+  val apply: ('a, 'b) t -> 'a -> 'b
+  val refl: ('a, 'a) t
+  val sym: ('a, 'b) t -> ('b, 'a) t
+end = struct
+  type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
+  let refl = (fun x -> x), (fun x -> x)
+  let apply (f, _) x = f x
+  let sym (f, g) = (g, f)
+end
+
+module rec Typ : sig
+  module type PAIR = sig
+    type t and t1 and t2
+    val eq: (t, t1 * t2) TypEq.t
+    val t1: t1 Typ.typ
+    val t2: t2 Typ.typ
+  end
+
+  type 'a typ =
+    | Int of ('a, int) TypEq.t
+    | String of ('a, string) TypEq.t
+    | Pair of (module PAIR with type t = 'a)
+end = Typ
+
+let int = Typ.Int TypEq.refl
+
+let str = Typ.String TypEq.refl
+
+let pair (type s1) (type s2) t1 t2 =
+  let module P = struct
+    type t = s1 * s2
+    type t1 = s1
+    type t2 = s2
+    let eq = TypEq.refl
+    let t1 = t1
+    let t2 = t2
+  end in
+  Typ.Pair (module P)
+
+open Typ
+let rec to_string: 'a. 'a Typ.typ -> 'a -> string =
+  fun (type s) t x ->
+    match (t : s typ) with
+    | Int eq -> string_of_int (TypEq.apply eq x)
+    | String eq -> Printf.sprintf "%S" (TypEq.apply eq x)
+    | Pair (module P) ->
+        let (x1, x2) = TypEq.apply P.eq x in
+        Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2)
+
+(* Wrapping maps *)
+module type MapT = sig
+  include Map.S
+  type data
+  type map
+  val of_t : data t -> map
+  val to_t : map -> data t
+end
+
+type ('k,'d,'m) map =
+    (module MapT with type key = 'k and type data = 'd and type map = 'm)
+
+let add (type k) (type d) (type m) (m:(k,d,m) map) x y s =
+   let module M =
+     (val m:MapT with type key = k and type data = d and type map = m) in
+   M.of_t (M.add x y (M.to_t s))
+
+module SSMap = struct
+  include Map.Make(String)
+  type data = string
+  type map = data t
+  let of_t x = x
+  let to_t x = x
+end
+
+let ssmap =
+  (module SSMap:
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (module struct include SSMap end :
+   MapT with type key = string and type data = string and type map = SSMap.map)
+;;
+
+let ssmap =
+  (let module S = struct include SSMap end in (module S) :
+  (module 
+   MapT with type key = string and type data = string and type map = SSMap.map))
+;;
+
+let ssmap =
+  (module SSMap: MapT with type key = _ and type data = _ and type map = _)
+;;
+
+let ssmap : (_,_,_) map = (module SSMap);;
+
+add ssmap;;

diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
new file mode 100644 (file)
index 0000000..32c49a2
--- /dev/null
+++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference
@@ -0,0 +1,166 @@
+
+# * * * * * * * * *                               val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = <fun>
+val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = <fun>
+val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
+module type S = sig type t val x : t end
+# val f : (module S with type t = int) -> int = <fun>
+# Characters 6-37:
+  let f (module M : S with type t = 'a) = M.x;; (* Error *)
+        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The type of this packed module contains variables:
+(module S with type t = 'a)
+# val f : (module S with type t = 'a) -> 'a = <fun>
+# - : int = 1
+#   type 'a s = { s : (module S with type t = 'a); }
+# - : int s = {s = <module>}
+# Characters 9-19:
+  let f {s=(module M)} = M.x;; (* Error *)
+           ^^^^^^^^^^
+Error: The type of this packed module contains variables:
+(module S with type t = 'a)
+# val f : 'a s -> 'a = <fun>
+#   type s = { s : (module S with type t = int); }
+# val f : s -> int = <fun>
+# val f : s -> s -> int = <fun>
+#   module type S = sig val x : int end
+# val f : (module S) -> int -> (module S) -> int = <fun>
+# Characters 8-37:
+  let m = (module struct let x = 3 end);; (* Error *)
+          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: The signature for this packaged module couldn't be inferred.
+# val m : (module S) = <module>
+# - : int = 7
+# - : int = 6
+#   - : int = 3
+# Characters 4-14:
+  let (module M) = m;; (* Error: only allowed in [let .. in] *)
+      ^^^^^^^^^^
+Error: Modules are not allowed in this pattern.
+# Characters 14-24:
+  class c = let (module M) = m in object end;; (* Error again *)
+                ^^^^^^^^^^
+Error: Modules are not allowed in this pattern.
+# module M : S
+#   module type S' = sig val f : int -> int end
+#       - : int = 6
+#                                                                                                                                                                                   module type S = sig type t type u val x : t * u end
+val f :
+  (module S with type t = int and type u = bool) list ->
+  (module S with type u = bool) list = <fun>
+module TypEq :
+  sig
+    type ('a, 'b) t
+    val apply : ('a, 'b) t -> 'a -> 'b
+    val refl : ('a, 'a) t
+    val sym : ('a, 'b) t -> ('b, 'a) t
+  end
+module rec Typ :
+  sig
+    module type PAIR =
+      sig
+        type t
+        and t1
+        and t2
+        val eq : (t, t1 * t2) TypEq.t
+        val t1 : t1 Typ.typ
+        val t2 : t2 Typ.typ
+      end
+    type 'a typ =
+        Int of ('a, int) TypEq.t
+      | String of ('a, string) TypEq.t
+      | Pair of (module PAIR with type t = 'a)
+  end
+val int : int Typ.typ = Int <abstr>
+val str : string Typ.typ = String <abstr>
+val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = <fun>
+val to_string : 'a Typ.typ -> 'a -> string = <fun>
+module type MapT =
+  sig
+    type key
+    type +'a t
+    val empty : 'a t
+    val is_empty : 'a t -> bool
+    val mem : key -> 'a t -> bool
+    val add : key -> 'a -> 'a t -> 'a t
+    val singleton : key -> 'a -> 'a t
+    val remove : key -> 'a t -> 'a t
+    val merge :
+      (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val for_all : (key -> 'a -> bool) -> 'a t -> bool
+    val exists : (key -> 'a -> bool) -> 'a t -> bool
+    val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+    val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+    val cardinal : 'a t -> int
+    val bindings : 'a t -> (key * 'a) list
+    val min_binding : 'a t -> key * 'a
+    val max_binding : 'a t -> key * 'a
+    val choose : 'a t -> key * 'a
+    val split : key -> 'a t -> 'a t * 'a option * 'a t
+    val find : key -> 'a t -> 'a
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+    type data
+    type map
+    val of_t : data t -> map
+    val to_t : map -> data t
+  end
+type ('k, 'd, 'm) map =
+    (module MapT with type data = 'd and type key = 'k and type map = 'm)
+val add : ('a, 'b, 'c) map -> 'a -> 'b -> 'c -> 'c = <fun>
+module SSMap :
+  sig
+    type key = String.t
+    type 'a t = 'a Map.Make(String).t
+    val empty : 'a t
+    val is_empty : 'a t -> bool
+    val mem : key -> 'a t -> bool
+    val add : key -> 'a -> 'a t -> 'a t
+    val singleton : key -> 'a -> 'a t
+    val remove : key -> 'a t -> 'a t
+    val merge :
+      (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+    val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+    val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+    val iter : (key -> 'a -> unit) -> 'a t -> unit
+    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+    val for_all : (key -> 'a -> bool) -> 'a t -> bool
+    val exists : (key -> 'a -> bool) -> 'a t -> bool
+    val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+    val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+    val cardinal : 'a t -> int
+    val bindings : 'a t -> (key * 'a) list
+    val min_binding : 'a t -> key * 'a
+    val max_binding : 'a t -> key * 'a
+    val choose : 'a t -> key * 'a
+    val split : key -> 'a t -> 'a t * 'a option * 'a t
+    val find : key -> 'a t -> 'a
+    val map : ('a -> 'b) -> 'a t -> 'b t
+    val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+    type data = string
+    type map = data t
+    val of_t : 'a -> 'a
+    val to_t : 'a -> 'a
+  end
+val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  <module>
+#         val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  <module>
+#           val ssmap :
+  (module MapT with type data = string and type key = string and type map = 
+   SSMap.map) =
+  <module>
+#       val ssmap :
+  (module MapT with type data = SSMap.data and type key = SSMap.key and type map = 
+   SSMap.map) =
+  <module>
+#   val ssmap : (SSMap.key, SSMap.data, SSMap.map) map = <module>
+#   - : SSMap.key -> SSMap.data -> SSMap.map -> SSMap.map = <fun>
+# 

diff --git a/testsuite/tests/typing-labels/.svnignore b/testsuite/tests/typing-labels/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/typing-labels/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/typing-labels/Makefile b/testsuite/tests/typing-labels/Makefile
index a226dd11fc1d32b20b703928752d25a6a5fb3f42..4ba0bffc51a49617bbbe56f5150b18b6313711fa 100644 (file)
--- a/testsuite/tests/typing-labels/Makefile
+++ b/testsuite/tests/typing-labels/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.several
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-modules-bugs/pr5343_bad.ml b/testsuite/tests/typing-modules-bugs/pr5343_bad.ml
new file mode 100644 (file)
index 0000000..0484c67
--- /dev/null
+++ b/testsuite/tests/typing-modules-bugs/pr5343_bad.ml
@@ -0,0 +1,13 @@
+module M : sig
+  type 'a t
+  type u = u t and v = v t
+  val f : int -> u
+  val g : v -> bool
+end = struct
+  type 'a t = 'a
+  type u = int and v = bool
+  let f x = x
+  let g x = x
+end;;
+
+let h (x : int) : bool = M.g (M.f x);;

diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml
index 82ea468f9ce3a248329040cde1ebdd6f69ae71f8..77c9d097023268b9fad8d3f84dd47cba5bad5912 100644 (file)
--- a/testsuite/tests/typing-modules/Test.ml
+++ b/testsuite/tests/typing-modules/Test.ml
@@ -3,3 +3,9 @@ module type S' = S with type t := int;;
 
 module type S = sig module rec M : sig end and N : sig end end;;
 module type S' = S with module M := String;;
+
+(* A subtle problem appearing with -principal *)
+type -'a t
+class type c = object method m : [ `A ] t end;;
+module M : sig val v : (#c as 'a) -> 'a end =
+  struct let v x = ignore (x :> c); x end;;

diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference
new file mode 100644 (file)
index 0000000..258b3ee
--- /dev/null
+++ b/testsuite/tests/typing-modules/Test.ml.principal.reference
@@ -0,0 +1,9 @@
+
+# module type S = sig type t and s = t end
+# module type S' = sig type s = int end
+#   module type S = sig module rec M : sig  end and N : sig  end end
+# module type S' = sig module rec N : sig  end end
+#       type -'a t
+class type c = object method m : [ `A ] t end
+#   module M : sig val v : (#c as 'a) -> 'a end
+# 

diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference
index 823cc1a84062e0077191c73661b4b26406ae98a5..258b3ee3de48d0c2f47a35184bee6ef5fd063c54 100644 (file)
--- a/testsuite/tests/typing-modules/Test.ml.reference
+++ b/testsuite/tests/typing-modules/Test.ml.reference
@@ -3,4 +3,7 @@
 # module type S' = sig type s = int end
 #   module type S = sig module rec M : sig  end and N : sig  end end
 # module type S' = sig module rec N : sig  end end
+#       type -'a t
+class type c = object method m : [ `A ] t end
+#   module M : sig val v : (#c as 'a) -> 'a end
 # 

diff --git a/testsuite/tests/typing-objects-bugs/Makefile b/testsuite/tests/typing-objects-bugs/Makefile
index 9375ddba6ff7656dc858ab6f45188321ab5a3ed4..1b07f20605758cb646e42f113ad86790572adbb7 100644 (file)
--- a/testsuite/tests/typing-objects-bugs/Makefile
+++ b/testsuite/tests/typing-objects-bugs/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-objects/.svnignore b/testsuite/tests/typing-objects/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/typing-objects/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml
index 212396cd192d7ca70a11df351b67bca19e71db44..ba3e64f01153e08145433bf6a817a164234e2c4e 100644 (file)
--- a/testsuite/tests/typing-objects/Exemples.ml
+++ b/testsuite/tests/typing-objects/Exemples.ml
@@ -216,7 +216,7 @@ end;;
 
 let c3 = new int_comparable3 15;;
 l#add (c3 :> int_comparable);;
-(new sorted_list ())#add c3;;   (* Echec : leq n'est pas binaire *)
+(new sorted_list ())#add c3;;   (* Error; strange message with -principal *)
 
 let sort (l : #comparable list) = Sort.list (fun x -> x#leq) l;;
 let pr l =

diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference
new file mode 100644 (file)
index 0000000..d6f9d6d
--- /dev/null
+++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference
@@ -0,0 +1,358 @@
+
+#           class point :
+  int ->
+  object val mutable x : int method get_x : int method move : int -> unit end
+#   val p : point = <obj>
+#   - : int = 7
+# - : unit = ()
+# - : int = 10
+#   val q : < get_x : int; move : int -> unit > = <obj>
+#   - : int * int = (10, 17)
+#           class color_point :
+  int ->
+  string ->
+  object
+    val c : string
+    val mutable x : int
+    method color : string
+    method get_x : int
+    method move : int -> unit
+  end
+#   val p' : color_point = <obj>
+#   - : int * string = (5, "red")
+#   val l : point list = [<obj>; <obj>]
+#   val get_x : < get_x : 'a; .. > -> 'a = <fun>
+# val set_x : < set_x : 'a; .. > -> 'a = <fun>
+# - : int list = [10; 5]
+#           Characters 7-96:
+  ......ref x_init = object
+    val mutable x = x_init
+    method get = x
+    method set y = x <- y
+  end..
+Error: Some type variables are unbound in this type:
+         class ref :
+           'a ->
+           object
+             val mutable x : 'a
+             method get : 'a
+             method set : 'a -> unit
+           end
+       The method get has type 'a where 'a is unbound
+#           class ref :
+  int ->
+  object val mutable x : int method get : int method set : int -> unit end
+#           class ['a] ref :
+  'a -> object val mutable x : 'a method get : 'a method set : 'a -> unit end
+#   - : int = 2
+#             class ['a] circle :
+  'a ->
+  object
+    constraint 'a = < move : int -> unit; .. >
+    val mutable center : 'a
+    method center : 'a
+    method move : int -> unit
+    method set_center : 'a -> unit
+  end
+#               class ['a] circle :
+  'a ->
+  object
+    constraint 'a = #point
+    val mutable center : 'a
+    method center : 'a
+    method move : int -> unit
+    method set_center : 'a -> unit
+  end
+#   val c : point circle = <obj>
+val c' : < color : string; get_x : int; move : int -> unit > circle = <obj>
+#           class ['a] color_circle :
+  'a ->
+  object
+    constraint 'a = #color_point
+    val mutable center : 'a
+    method center : 'a
+    method color : string
+    method move : int -> unit
+    method set_center : 'a -> unit
+  end
+#   Characters 28-29:
+  let c'' = new color_circle p;;
+                             ^
+Error: This expression has type point but an expression was expected of type
+         #color_point
+       The first object type has no method color
+# val c'' : color_point color_circle = <obj>
+#   - : color_point circle = <obj>
+# Characters 0-21:
+  (c'' :> point circle);;                 (* Echec *)
+  ^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         color_point color_circle =
+           < center : color_point; color : string; move : int -> unit;
+             set_center : color_point -> unit >
+       is not a subtype of
+         point circle =
+           < center : point; move : int -> unit; set_center : point -> unit > 
+Type point = point is not a subtype of color_point = color_point 
+# Characters 9-55:
+  fun x -> (x : color_point color_circle :> point circle);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         color_point color_circle =
+           < center : color_point; color : string; move : int -> unit;
+             set_center : color_point -> unit >
+       is not a subtype of
+         point circle =
+           < center : point; move : int -> unit; set_center : point -> unit > 
+Type point = point is not a subtype of color_point = color_point 
+#         class printable_point :
+  int ->
+  object
+    val mutable x : int
+    method get_x : int
+    method move : int -> unit
+    method print : unit
+  end
+#   val p : printable_point = <obj>
+# 7- : unit = ()
+#                     Characters 85-102:
+    inherit printable_point y as super
+            ^^^^^^^^^^^^^^^^^
+Warning 13: the following instance variables are overridden by the class printable_point :
+  x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class printable_color_point :
+  int ->
+  string ->
+  object
+    val c : string
+    val mutable x : int
+    method color : string
+    method get_x : int
+    method move : int -> unit
+    method print : unit
+  end
+#   val p' : printable_color_point = <obj>
+# (7, red)- : unit = ()
+#           class functional_point :
+  int ->
+  object ('a) val x : int method get_x : int method move : int -> 'a end
+#   val p : functional_point = <obj>
+#   - : int = 7
+# - : int = 10
+# - : int = 7
+#   - : #functional_point -> functional_point = <fun>
+#                                                                       class virtual ['a] lst :
+  unit ->
+  object
+    method virtual hd : 'a
+    method iter : ('a -> unit) -> unit
+    method map : ('a -> 'a) -> 'a lst
+    method virtual null : bool
+    method print : ('a -> unit) -> unit
+    method virtual tl : 'a lst
+  end
+and ['a] nil :
+  unit ->
+  object
+    method hd : 'a
+    method iter : ('a -> unit) -> unit
+    method map : ('a -> 'a) -> 'a lst
+    method null : bool
+    method print : ('a -> unit) -> unit
+    method tl : 'a lst
+  end
+and ['a] cons :
+  'a ->
+  'a lst ->
+  object
+    val h : 'a
+    val t : 'a lst
+    method hd : 'a
+    method iter : ('a -> unit) -> unit
+    method map : ('a -> 'a) -> 'a lst
+    method null : bool
+    method print : ('a -> unit) -> unit
+    method tl : 'a lst
+  end
+#   val l1 : int lst = <obj>
+#   (3::10::[])- : unit = ()
+#   val l2 : int lst = <obj>
+# (4::11::[])- : unit = ()
+#       val map_list : ('a -> 'b) -> 'a lst -> 'b lst = <fun>
+#   val p1 : printable_color_point lst = <obj>
+# ((3, red)::(10, red)::[])- : unit = ()
+#           class virtual comparable :
+  unit -> object ('a) method virtual leq : 'a -> bool end
+#             class int_comparable :
+  int -> object ('a) val x : int method leq : 'a -> bool method x : int end
+#           class int_comparable2 :
+  int ->
+  object ('a)
+    val x : int
+    val mutable x' : int
+    method leq : 'a -> bool
+    method set_x : int -> unit
+    method x : int
+  end
+#                         class ['a] sorted_list :
+  unit ->
+  object
+    constraint 'a = #comparable
+    val mutable l : 'a list
+    method add : 'a -> unit
+    method hd : 'a
+  end
+#   val l : _#comparable sorted_list = <obj>
+# val c : int_comparable = <obj>
+# - : unit = ()
+#   val c2 : int_comparable2 = <obj>
+# Characters 6-28:
+  l#add (c2 :> int_comparable);;      (* Echec : 'a comp2 n'est un sous-type *)
+        ^^^^^^^^^^^^^^^^^^^^^^
+Error: Type
+         int_comparable2 =
+           < leq : int_comparable2 -> bool; set_x : int -> unit; x : int >
+       is not a subtype of
+         int_comparable = < leq : int_comparable -> bool; x : int > 
+Type int_comparable = < leq : int_comparable -> bool; x : int >
+is not a subtype of
+  int_comparable2 =
+    < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > 
+# - : unit = ()
+#             class int_comparable3 :
+  int ->
+  object
+    val mutable x : int
+    method leq : int_comparable -> bool
+    method setx : int -> unit
+    method x : int
+  end
+#   val c3 : int_comparable3 = <obj>
+# - : unit = ()
+# Characters 25-27:
+  (new sorted_list ())#add c3;;   (* Error; strange message with -principal *)
+                           ^^
+Error: This expression has type
+         int_comparable3 =
+           < leq : int_comparable -> bool; setx : int -> unit; x : int >
+       but an expression was expected of type
+         #comparable as 'a = < leq : 'a -> bool; .. >
+       Type int_comparable = < leq : int_comparable -> bool; x : int >
+       is not compatible with type 'a = < leq : 'a -> bool; .. > 
+       The first object type has no method setx
+#   val sort : (#comparable as 'a) list -> 'a list = <fun>
+#     Characters 13-66:
+    List.map (fun c -> print_int c#x; print_string " ") l;
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 10: this expression should have type unit.
+val pr : < x : int; .. > list -> unit = <fun>
+#   val l : int_comparable list = [<obj>; <obj>; <obj>]
+# 5 2 4 
+- : unit = ()
+# 2 4 5 
+- : unit = ()
+# val l : int_comparable2 list = [<obj>; <obj>]
+# 2 0 
+- : unit = ()
+# 0 2 
+- : unit = ()
+#     val min : (#comparable as 'a) -> 'a -> 'a = <fun>
+#   - : int = 7
+# - : int = 3
+#                                 class ['a] link :
+  'a ->
+  object ('b)
+    val mutable next : 'b option
+    val mutable x : 'a
+    method append : 'b option -> unit
+    method next : 'b option
+    method set_next : 'b option -> unit
+    method set_x : 'a -> unit
+    method x : 'a
+  end
+#                   class ['a] double_link :
+  'a ->
+  object ('b)
+    val mutable next : 'b option
+    val mutable prev : 'b option
+    val mutable x : 'a
+    method append : 'b option -> unit
+    method next : 'b option
+    method prev : 'b option
+    method set_next : 'b option -> unit
+    method set_prev : 'b option -> unit
+    method set_x : 'a -> unit
+    method x : 'a
+  end
+#           val fold_right : ('a -> 'b -> 'b) -> 'a #link option -> 'b -> 'b = <fun>
+#                                       class calculator :
+  unit ->
+  object ('a)
+    val mutable acc : float
+    val mutable arg : float
+    val mutable equals : 'a -> float
+    method acc : float
+    method add : 'a
+    method arg : float
+    method enter : float -> 'a
+    method equals : float
+    method sub : 'a
+  end
+#   - : float = 5.
+# - : float = 1.5
+# - : float = 15.
+#                       class calculator :
+  unit ->
+  object ('a)
+    val mutable acc : float
+    val mutable arg : float
+    val mutable equals : 'a -> float
+    method acc : float
+    method add : 'a
+    method arg : float
+    method enter : float -> 'a
+    method equals : float
+    method sub : 'a
+  end
+#   - : float = 5.
+# - : float = 1.5
+# - : float = 15.
+#                                 class calculator :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+and calculator_add :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+and calculator_sub :
+  float ->
+  float ->
+  object
+    val acc : float
+    val arg : float
+    method add : calculator
+    method enter : float -> calculator
+    method equals : float
+    method sub : calculator
+  end
+#   val calculator : calculator = <obj>
+#   - : float = 5.
+# - : float = 1.5
+# - : float = 15.
+# 

diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference
index 6be5b69483ccb96e7c2124f4dea16c5740ccf1b8..128d1be70d865155cf2594be6e33f81ee48cdff6 100644 (file)
--- a/testsuite/tests/typing-objects/Exemples.ml.reference
+++ b/testsuite/tests/typing-objects/Exemples.ml.reference
@@ -231,7 +231,7 @@ is not a subtype of
 #   val c3 : int_comparable3 = <obj>
 # - : unit = ()
 # Characters 25-27:
-  (new sorted_list ())#add c3;;   (* Echec : leq n'est pas binaire *)
+  (new sorted_list ())#add c3;;   (* Error; strange message with -principal *)
                            ^^
 Error: This expression has type
          int_comparable3 =

diff --git a/testsuite/tests/typing-objects/Makefile b/testsuite/tests/typing-objects/Makefile
index 9add15574f085c06eee00ba0f8fcc28747d1a387..5f42b70577daa3d318645ab760281a30482bdb48 100644 (file)
--- a/testsuite/tests/typing-objects/Makefile
+++ b/testsuite/tests/typing-objects/Makefile
@@ -1,3 +1,4 @@
-include ../../makefiles/Makefile.toplevel
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
 

diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
index 19d20d8821ea6202ae555b223ade8be53a52e601..c7a5cb3d1687d3a09937ad238281ed4e542e1eb7 100644 (file)
--- a/testsuite/tests/typing-objects/Tests.ml
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -302,3 +302,26 @@ end;;
 let x = new d () in x#n, x#o;;
 
 class c () = object method virtual m : int method private m = 1 end;;
+
+(* Marshaling (cf. PR#5436) *)
+
+Oo.id (object end);;
+Oo.id (object end);;
+Oo.id (object end);;
+let o = object end in
+  let s = Marshal.to_string o [] in
+  let o' : < > = Marshal.from_string s 0 in
+  let o'' : < > = Marshal.from_string s 0 in
+  (Oo.id o, Oo.id o', Oo.id o'');;
+
+let o = object val x = 33 method m = x end in
+  let s = Marshal.to_string o [Marshal.Closures] in
+  let o' : <m:int> = Marshal.from_string s 0 in
+  let o'' : <m:int> = Marshal.from_string s 0 in
+  (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);;
+
+let o = object val x = 33 val y = 44 method m = x end in
+  let s = Marshal.to_string o [Marshal.Closures] in
+  let o' : <m:int> = Marshal.from_string s 0 in
+  let o'' : <m:int> = Marshal.from_string s 0 in
+  (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);;

diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference
new file mode 100644 (file)
index 0000000..1f89125
--- /dev/null
+++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference
@@ -0,0 +1,302 @@
+
+#   - : < x : int > ->
+    < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
+= <fun>
+#               class ['a] c : unit -> object constraint 'a = int method f : int c end
+and ['a] d : unit -> object constraint 'a = int method f : int c end
+#                 Characters 238-275:
+  ........d () = object
+    inherit ['a] c ()
+  end..
+Error: Some type variables are unbound in this type:
+         class d : unit -> object method f : 'a -> unit end
+       The method f has type 'a -> unit where 'a is unbound
+#             class virtual c : unit -> object  end
+and ['a] d :
+  unit -> object constraint 'a = < x : int; .. > method f : 'a -> int end
+#                 class ['a] c : unit -> object constraint 'a = int end
+and ['a] d : unit -> object constraint 'a = int #c end
+# *             class ['a] c :
+  'a -> object ('a) constraint 'a = < f : 'a; .. > method f : 'a end
+# - : ('a c as 'a) -> 'a = <fun>
+# *           Characters 134-176:
+  ......x () = object
+    method virtual f : int
+  end..
+Error: This class should be virtual. The following methods are undefined : f
+#               Characters 139-147:
+  class virtual c ((x : 'a): < f : int >) = object (_ : 'a) end
+                                                   ^^^^^^^^
+Error: This pattern cannot match self: it only matches values of type
+       < f : int >
+#           Characters 38-110:
+  ......['a] c () = object
+    constraint 'a = int
+    method f x = (x : bool c)
+  end..
+Error: The abbreviation c is used with parameters bool c
+       wich are incompatible with constraints int c
+#             class ['a, 'b] c :
+  unit ->
+  object
+    constraint 'a = int -> 'c
+    constraint 'b = 'a * < x : 'b > * 'c * 'd
+    method f : 'a -> 'b -> unit
+  end
+#     class ['a, 'b] d :
+  unit ->
+  object
+    constraint 'a = int -> 'c
+    constraint 'b = 'a * < x : 'b > * 'c * 'd
+    method f : 'a -> 'b -> unit
+  end
+#     val x : '_a list ref = {contents = []}
+#     Characters 6-50:
+  ......['a] c () = object
+    method f = (x : 'a)
+  end..
+Error: The type of this class,
+       class ['a] c :
+         unit -> object constraint 'a = '_b list ref method f : 'a end,
+       contains type variables that cannot be generalized
+#       Characters 24-52:
+  type 'a c = <f : 'a c; g : 'a d>
+      ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: In the definition of d, type int c should be 'a c
+#   type 'a c = < f : 'a c; g : 'a d >
+and 'a d = < f : 'a c >
+#   type 'a c = < f : 'a c >
+and 'a d = < f : int c >
+#   type 'a u = < x : 'a >
+and 'a t = 'a t u
+#   Characters 18-32:
+  and 'a t = 'a t u;;
+     ^^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+# type 'a u = 'a
+# Characters 5-18:
+  type t = t u * t u;;
+       ^^^^^^^^^^^^^
+Error: The type abbreviation t is cyclic
+#   type t = < x : 'a > as 'a
+# type 'a u = 'a
+# - : t -> t u -> bool = <fun>
+# - : t -> t u -> bool = <fun>
+#                         module M :
+  sig
+    class ['a, 'b] c :
+      int ->
+      'b ->
+      object
+        constraint 'a = int -> bool
+        val x : float list
+        val y : 'b
+        method f : 'a -> unit
+        method g : 'b
+      end
+  end
+#                   module M' :
+  sig
+    class virtual ['a, 'b] c :
+      int ->
+      'b ->
+      object
+        constraint 'a = int -> bool
+        val x : float list
+        val y : 'b
+        method f : 'a -> unit
+        method g : 'b
+      end
+  end
+# class ['a, 'b] d :
+  unit ->
+  'b ->
+  object
+    constraint 'a = int -> bool
+    val x : float list
+    val y : 'b
+    method f : 'a -> unit
+    method g : 'b
+  end
+# class ['a, 'b] e :
+  unit ->
+  'b ->
+  object
+    constraint 'a = int -> bool
+    val x : float list
+    val y : 'b
+    method f : 'a -> unit
+    method g : 'b
+  end
+# - : string = "a"
+# - : int = 10
+# - : float = 7.1
+# # - : bool = true
+#     module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
+#   module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
+# - : ('a #M.c as 'b) -> 'b = <fun>
+# - : ('a #M'.c as 'b) -> 'b = <fun>
+# class ['a] c : 'a #c -> object  end
+# class ['a] c : 'a #c -> object  end
+#     class c : unit -> object method f : int end
+and d : unit -> object method f : int end
+# class e : unit -> object method f : int end
+# - : int = 2
+# Characters 30-34:
+  class c () = object val x = - true val y = -. () end;;
+                                ^^^^
+Error: This expression has type bool but an expression was expected of type
+         int
+#   class c : unit -> object method f : int method g : int method h : int end
+# class d : unit -> object method h : int method i : int method j : int end
+#               class e :
+  unit ->
+  object
+    method f : int
+    method g : int
+    method h : int
+    method i : int
+    method j : int
+  end
+# val e : e = <obj>
+# - : int * int * int * int * int = (1, 3, 2, 2, 3)
+#   class c : 'a -> object val a : 'a val x : int val y : int val z : int end
+# class d : 'a -> object val b : 'a val t : int val u : int val z : int end
+#                             Characters 43-46:
+    inherit c 5
+            ^^^
+Warning 13: the following instance variables are overridden by the class c :
+  x
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 53-58:
+    val y = 3
+        ^^^^^
+Warning 13: the instance variable y is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 81-84:
+    inherit d 7
+            ^^^
+Warning 13: the following instance variables are overridden by the class d :
+  t z
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+Characters 91-96:
+    val u = 3
+        ^^^^^
+Warning 13: the instance variable u is overridden.
+The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)
+class e :
+  unit ->
+  object
+    val a : int
+    val b : int
+    val t : int
+    val u : int
+    val x : int
+    val y : int
+    val z : int
+    method a : int
+    method b : int
+    method t : int
+    method u : int
+    method x : int
+    method y : int
+    method z : int
+  end
+# val e : e = <obj>
+# - : int * int * int * int * int * int * int = (1, 3, 2, 2, 3, 5, 7)
+#             class c :
+  int ->
+  int -> object val x : int val y : int method x : int method y : int end
+# class d :
+  int ->
+  int -> object val x : int val y : int method x : int method y : int end
+# - : int * int = (1, 2)
+# - : int * int = (1, 2)
+#     class ['a] c : 'a -> object  end
+# - : 'a -> 'a c = <fun>
+#     * * * * * * * * * * * * * * * * * * * * *                             module M : sig class c : unit -> object method xc : int end end
+#         class d : unit -> object val x : int method xc : int method xd : int end
+# - : int * int = (1, 2)
+#         Characters 7-156:
+  ......virtual ['a] matrix (sz, init : int * 'a) = object
+    val m = Array.create_matrix sz sz init
+    method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a)
+  end..
+Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a >
+       but is used with type < m : 'a array array; .. >
+#   class c : unit -> object method m : c end
+# - : c = <obj>
+# module M : sig class c : unit -> object method m : c end end
+# - : M.c = <obj>
+#   type uu = A of int | B of (< leq : 'a > as 'a)
+#   class virtual c : unit -> object ('a) method virtual m : 'a end
+#         module S : sig val f : (#c as 'a) -> 'a end
+#         Characters 12-43:
+  ............struct
+    let f (x : #c) = x
+  end......
+Error: Signature mismatch:
+       Modules do not match:
+         sig val f : (#c as 'a) -> 'a end
+       is not included in
+         sig val f : #c -> #c end
+       Values do not match:
+         val f : (#c as 'a) -> 'a
+       is not included in
+         val f : #c -> #c
+#   Characters 32-55:
+  module M = struct type t = int class t () = object end end;;
+                                 ^^^^^^^^^^^^^^^^^^^^^^^
+Error: Multiple definition of the type name t.
+       Names must be unique in a given structure or signature.
+#   - : < m : (< m : 'a > as 'b) -> 'b as 'a; .. > -> 'b = <fun>
+#   Characters 10-39:
+  fun x -> (x : int -> bool :> 'a -> 'a);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int 
+# Characters 9-40:
+  fun x -> (x : int -> bool :> int -> int);;
+           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Type int -> bool is not a subtype of int -> int 
+# - : <  > -> <  > = <fun>
+# - : < .. > -> <  > = <fun>
+#   val x : '_a list ref = {contents = []}
+#   module F : functor (X : sig  end) -> sig type t = int end
+# - : < m : int > list ref = {contents = []}
+#   type 'a t
+# Characters 9-19:
+  fun (x : 'a t as 'a) -> ();;
+           ^^^^^^^^^^
+Error: This alias is bound to type 'a t but is used as an instance of type 'a
+       The type variable 'a occurs inside 'a t
+# Characters 19-20:
+  fun (x : 'a t) -> (x : 'a); ();;
+                     ^
+Error: This expression has type 'a t but an expression was expected of type
+         'a
+       The type variable 'a occurs inside 'a t
+# type 'a t = < x : 'a >
+# - : ('a t as 'a) -> unit = <fun>
+# Characters 18-26:
+  fun (x : 'a t) -> (x : 'a); ();;
+                    ^^^^^^^^
+Warning 10: this expression should have type unit.
+- : ('a t as 'a) t -> unit = <fun>
+#         class ['a] c :
+  unit ->
+  object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end
+#       class ['a] c :
+  unit ->
+  object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end
+#         class c : unit -> object method private m : int method n : int end
+#         class d :
+  unit -> object method private m : int method n : int method o : int end
+#   - : int * int = (1, 1)
+#   class c : unit -> object method m : int end
+#       - : int = 15
+# - : int = 16
+# - : int = 17
+#         - : int * int * int = (18, 19, 20)
+#           - : int * int * int * int * int = (21, 22, 23, 33, 33)
+#           - : int * int * int * int * int = (24, 25, 26, 33, 33)
+# 

diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference
index 74b1c25f940f7b08447d6f0fe6c3b7f2af4ef61e..cbeaa61424148ce9edc1e8f87ed0de8ebf4f404f 100644 (file)
--- a/testsuite/tests/typing-objects/Tests.ml.reference
+++ b/testsuite/tests/typing-objects/Tests.ml.reference
@@ -134,8 +134,8 @@ Error: The type abbreviation t is cyclic
 # # - : bool = true
 #     module M : sig class ['a] c : unit -> object method f : 'a -> unit end end
 #   module M' : sig class ['a] c : unit -> object method f : 'a -> unit end end
-# - : ('b #M.c as 'a) -> 'a = <fun>
-# - : ('b #M'.c as 'a) -> 'a = <fun>
+# - : ('a #M.c as 'b) -> 'b = <fun>
+# - : ('a #M'.c as 'b) -> 'b = <fun>
 # class ['a] c : 'a #c -> object  end
 # class ['a] c : 'a #c -> object  end
 #     class c : unit -> object method f : int end
@@ -268,18 +268,20 @@ Error: Type int -> bool is not a subtype of int -> int
   fun (x : 'a t as 'a) -> ();;
            ^^^^^^^^^^
 Error: This alias is bound to type 'a t but is used as an instance of type 'a
+       The type variable 'a occurs inside 'a t
 # Characters 19-20:
   fun (x : 'a t) -> (x : 'a); ();;
                      ^
 Error: This expression has type 'a t but an expression was expected of type
          'a
+       The type variable 'a occurs inside 'a t
 # type 'a t = < x : 'a >
 # - : ('a t as 'a) -> unit = <fun>
 # Characters 18-26:
   fun (x : 'a t) -> (x : 'a); ();;
                     ^^^^^^^^
 Warning 10: this expression should have type unit.
-- : ('a t as 'a) -> unit = <fun>
+- : ('a t as 'a) t -> unit = <fun>
 #         class ['a] c :
   unit -> object constraint 'a = (< .. > as 'b) -> unit method m : 'a end
 #       class ['a] c :
@@ -290,4 +292,10 @@ Warning 10: this expression should have type unit.
   unit -> object method private m : int method n : int method o : int end
 #   - : int * int = (1, 1)
 #   class c : unit -> object method m : int end
+#       - : int = 15
+# - : int = 16
+# - : int = 17
+#         - : int * int * int = (18, 19, 20)
+#           - : int * int * int * int * int = (21, 22, 23, 33, 33)
+#           - : int * int * int * int * int = (24, 25, 26, 33, 33)
 # 

diff --git a/testsuite/tests/typing-poly-bugs/Makefile b/testsuite/tests/typing-poly-bugs/Makefile
new file mode 100644 (file)
index 0000000..1b07f20
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/Makefile
@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-poly-bugs/pr5322_ok.ml b/testsuite/tests/typing-poly-bugs/pr5322_ok.ml
new file mode 100644 (file)
index 0000000..a24a676
--- /dev/null
+++ b/testsuite/tests/typing-poly-bugs/pr5322_ok.ml
@@ -0,0 +1,7 @@
+type 'par t = 'par
+module M : sig val x : <m : 'a. 'a> end =
+  struct let x : <m : 'a. 'a t> = Obj.magic () end
+
+let ident v = v
+class alias = object method alias : 'a . 'a t -> 'a = ident end
+

diff --git a/testsuite/tests/typing-poly/.svnignore b/testsuite/tests/typing-poly/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/typing-poly/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/typing-poly/Makefile b/testsuite/tests/typing-poly/Makefile
index 9add15574f085c06eee00ba0f8fcc28747d1a387..5f42b70577daa3d318645ab760281a30482bdb48 100644 (file)
--- a/testsuite/tests/typing-poly/Makefile
+++ b/testsuite/tests/typing-poly/Makefile
@@ -1,3 +1,4 @@
-include ../../makefiles/Makefile.toplevel
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
 

diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml
index b5835b3daaf5db6ffb62734d0d82551f0f345dda..2456780f71615e4df8d3e991cefe90c7e38fb6e3 100644 (file)
--- a/testsuite/tests/typing-poly/poly.ml
+++ b/testsuite/tests/typing-poly/poly.ml
@@ -557,18 +557,31 @@ let f5 x =
 let f6 x =
   (x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
 
+(* Keep sharing the epsilons *)
+let f x = if true then (x : < m : 'a. 'a -> 'a >) else x;;
+fun x -> (f x)#m;; (* Warning 18 *)
+let f (x, y) = if true then (x : < m : 'a. 'a -> 'a >) else x;;
+fun x -> (f (x,x))#m;; (* Warning 18 *)
+let f x = if true then [| (x : < m : 'a. 'a -> 'a >) |] else [|x|];;
+fun x -> (f x).(0)#m;; (* Warning 18 *)
+
 (* Not really principal? *)
 class c = object method id : 'a. 'a -> 'a = fun x -> x end;;
 type u = c option;;
 let just = function None -> failwith "just" | Some x -> x;;
 let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
 let g x =
-  let none = match None with y -> ignore [y;(None:u)]; y in
+  let none = (fun y -> ignore [y;(None:u)]; y) None in
   let x = List.hd [Some x; none] in (just x)#id;;
 let h x =
   let none = let y = None in ignore [y;(None:u)]; y in
   let x = List.hd [Some x; none] in (just x)#id;;
 
+(* Only solved for parameterless abbreviations *)
+type 'a u = c option;;
+let just = function None -> failwith "just" | Some x -> x;;
+let f x = let l = [Some x; (None : _ u)] in (just(List.hd l))#id;;
+
 (* polymorphic recursion *)
 
 let rec f : 'a. 'a -> _ = fun x -> 1 and g x = f x;;
@@ -620,5 +633,21 @@ let l : t = { f = lazy (raise Not_found)};;
 
 (* variant *)
 type t = {f: 'a. 'a -> unit};;
-{f=fun ?x y -> ()};;
-{f=fun ?x y -> y};; (* fail *)
+let f ?x y = () in {f};;
+let f ?x y = y in {f};; (* fail *)
+
+(* Polux Moon caml-list 2011-07-26 *)
+module Polux = struct
+  type 'par t = 'par
+  let ident v = v
+  class alias = object method alias : 'a . 'a t -> 'a = ident end
+  let f (x : <m : 'a. 'a t>) = (x : <m : 'a. 'a>)
+end;;
+
+(* PR#5560 *)
+
+let (a, b) = (raise Exit : int * int);;
+type t = { foo : int }
+let {foo} = (raise Exit : t);;
+type s = A of int
+let (A x) = (raise Exit : s);;

diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference
index 63281ae0db7b93917f3086a984d05b52f42da185..55bfd0f4ccb8ac72f06321a4e6835713e09dd863 100644 (file)
--- a/testsuite/tests/typing-poly/poly.ml.principal.reference
+++ b/testsuite/tests/typing-poly/poly.ml.principal.reference
@@ -3,17 +3,17 @@
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
 # val f : 'a list -> 'a fold = <fun>
 # - : int = 6
-#               class ['a] ilist :
-  'a list ->
-  object ('b)
-    val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+#               class ['b] ilist :
+  'b list ->
+  object ('c)
+    val l : 'b list
+    method add : 'b -> 'c
+    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
   end
 #         class virtual ['a] vlist :
-  object ('b)
-    method virtual add : 'a -> 'b
-    method virtual fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  object ('c)
+    method virtual add : 'a -> 'c
+    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #             class ilist2 :
   int list ->
@@ -25,52 +25,52 @@
 #             val ilist2 : 'a list -> 'a vlist = <fun>
 #             class ['a] ilist3 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #               class ['a] ilist4 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #                 class ['a] ilist5 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
-    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #                 class ['a] ilist6 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
-    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #       class virtual ['a] olist :
-  object method virtual fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
 #         class ['a] onil :
-  object method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
 #             class ['a] ocons :
   hd:'a ->
   tl:'a olist ->
   object
     val hd : 'a
     val tl : 'a olist
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
 #               class ['a] ostream :
   hd:'a ->
   tl:'a ostream ->
   object
     val hd : 'a
-    val tl : < empty : bool; fold : 'b. f:('a -> 'b -> 'b) -> init:'b -> 'b >
+    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
     method empty : bool
     method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
@@ -123,9 +123,9 @@ val d : float = 11.4536240470737098
 #   Characters 41-42:
   let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
                                            ^
-Error: This expression has type < m : 'a. 'a -> 'a list >
-       but an expression was expected of type < m : 'a. 'a -> 'b >
-       The universal variable 'a would escape its scope
+Error: This expression has type < m : 'b. 'b -> 'b list >
+       but an expression was expected of type < m : 'b. 'b -> 'c >
+       The universal variable 'b would escape its scope
 #           class id : object method id : 'a -> 'a end
 #         class type id_spec = object method id : 'a -> 'a end
 #       class id_impl : object method id : 'a -> 'a end
@@ -142,13 +142,13 @@ Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
 #           Characters 80-85:
     method id _ = x
               ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
 #                 Characters 92-159:
   ............x =
       match r with
         None -> r <- Some x; x
       | Some y -> y
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
 #         class c : object method m : 'a -> 'b -> 'a end
 #     val f1 : id -> int * bool = <fun>
 #   val f2 : id -> int * bool = <fun>
@@ -175,9 +175,9 @@ val f4 : id -> int * bool = <fun>
 Error: The type abbreviation foo is cyclic
 #     class ['a] bar : 'a -> object  end
 #   type 'a foo = 'a foo bar
-#   - : (< m : 'b. 'b * 'a > as 'a) -> 'c * (< m : 'e. 'e * 'd > as 'd) = <fun>
-# - : (< m : 'b. 'a * 'b list > as 'a) ->
-    (< m : 'd. 'c * 'd list > as 'c) * 'e list
+#   - : (< m : 'a. 'a * 'b > as 'b) -> 'c * (< m : 'a. 'a * 'd > as 'd) = <fun>
+# - : (< m : 'a. 'b * 'a list > as 'b) ->
+    (< m : 'a. 'c * 'a list > as 'c) * 'd list
 = <fun>
 # val f :
   (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
@@ -186,11 +186,11 @@ Error: The type abbreviation foo is cyclic
 # - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
     (< m : 'c; n : < p : 'e. < m : 'e; n : 'd; .. > as 'e > as 'd; .. > as 'c)
 = <fun>
-# - : (< m : 'b. 'b * < p : 'd. 'd * 'c * 'a > as 'c > as 'a) ->
+# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
     ('f *
-     < p : 'g.
-             'g * 'e *
-             (< m : 'i. 'i * < p : 'k. 'k * 'j * 'h > as 'j > as 'h) >
+     < p : 'b.
+             'b * 'e *
+             (< m : 'a. 'a * < p : 'b0. 'b0 * 'h * 'g > as 'h > as 'g) >
      as 'e)
 = <fun>
 #   - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = <fun>
@@ -199,14 +199,14 @@ Error: The type abbreviation foo is cyclic
 #   type record = { r : < id : 'a. 'a -> 'a >; }
 # - : record -> 'a -> 'a = <fun>
 # - : record -> 'a -> 'a = <fun>
-#       class myself : object ('a) method self : 'b -> 'a end
+#       class myself : object ('b) method self : 'a -> 'b end
 #                       class number :
-  object ('a)
+  object ('b)
     val num : int
     method num : int
-    method prev : 'a
-    method succ : 'a
-    method switch : zero:(unit -> 'b) -> prev:('a -> 'b) -> 'b
+    method prev : 'b
+    method succ : 'b
+    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
   end
 #     val id : 'a -> 'a = <fun>
 #       class c : object method id : 'a -> 'a end
@@ -216,14 +216,14 @@ Error: The type abbreviation foo is cyclic
     val mutable count : int
     method count : int
     method id : 'a -> 'a
-    method old : 'b -> 'b
+    method old : 'a -> 'a
   end
 #             class ['a] olist :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method cons : 'a -> 'b
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method cons : 'a -> 'c
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
   end
 #   val sum : int #olist -> int = <fun>
 #   val count : 'a #olist -> int = <fun>
@@ -244,16 +244,16 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
 # Characters 17-25:
   let bad = {bad = ref None};;
                    ^^^^^^^^
-Error: This field value has type 'a option ref which is less general than
-         'b. 'b option ref
+Error: This field value has type 'b option ref which is less general than
+         'a. 'a option ref
 # type bad2 = { mutable bad2 : 'a. 'a option ref option; }
 # val bad2 : bad2 = {bad2 = None}
 # Characters 13-28:
   bad2.bad2 <- Some (ref None);;
                ^^^^^^^^^^^^^^^
-Error: This field value has type 'a option ref option
-       which is less general than 'b. 'b option ref option
-#       val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = <fun>
+Error: This field value has type 'b option ref option
+       which is less general than 'a. 'a option ref option
+#       val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = <fun>
 # val f :
   < m : 'a. 'a * (< p : int * 'b > as 'b) > ->
   (< p : int * 'c > as 'c) -> unit = <fun>
@@ -265,10 +265,10 @@ Error: This field value has type 'a option ref option
 #           Characters 145-166:
   object method virtual visit : 'a.('a visitor -> 'a) end;;
                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This type scheme cannot quantify 'a :
-it escapes this scope.
+Error: The universal type variable 'a cannot be generalized:
+       it escapes its scope.
 #                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b >
+type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
 class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
 type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
 #     Characters 20-25:
@@ -281,7 +281,7 @@ type t = [ `A of t a ]
   type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
                                                     ^^^^^^^^^
 Error: Constraints are not satisfied in this type.
-Type ('a, 'b) t should be an instance of ('c, 'c) t
+       Type ('a, 'b) t should be an instance of ('c, 'c) t
 #     type 'a t = 'a
 and u = int t
 #     type 'a t constraint 'a = int
@@ -289,7 +289,7 @@ and u = int t
   type 'a u = 'a and 'a v = 'a u t;;
                             ^^^^^^
 Error: Constraints are not satisfied in this type.
-Type 'a u t should be an instance of int t
+       Type 'a u t should be an instance of int t
 # type 'a u = 'a constraint 'a = int
 and 'a v = 'a u t constraint 'a = int
 #     type g = int
@@ -298,7 +298,7 @@ and 'a v = 'a u t constraint 'a = int
   type 'a u = 'a and 'a v = 'a u t;;
                             ^^^^^^
 Error: Constraints are not satisfied in this type.
-Type 'a u t should be an instance of g t
+       Type 'a u t should be an instance of g t
 # type 'a u = 'a constraint 'a = g
 and 'a v = 'a u t constraint 'a = int
 #     Characters 38-58:
@@ -350,10 +350,10 @@ Warning 11: this match case is unused.
   type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] 
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Constraints are not satisfied in this type.
-Type
-([> `B of 'a ], 'a) b as 'a
-should be an instance of
-(('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b
+       Type
+       ([> `B of 'a ], 'a) b as 'a
+       should be an instance of
+       (('b, [> `A of ('d, 'c) a as 'd ] as 'c) a as 'b, 'c) b
 #     *                           class type ['a, 'b] a =
   object
     constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
@@ -412,9 +412,9 @@ Error: This object is expected to have type < x : int; .. >
 #         Characters 76-77:
     (x : <m : 'a. 'a * (<m:'b. 'a * <m:'c. 'c * 'bar> > as 'bar) >);;
      ^
-Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
+Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
        but an expression was expected of type
-         < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) >
+         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
        Types for method m are incompatible
 #         Characters 176-177:
   let f (x : foo') = (x : bar');;
@@ -422,70 +422,70 @@ Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
 Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
        but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
        Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > 
+         'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > 
        Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         < m : 'b. 'b * 'a bar > 
+         < m : 'c. 'c * 'a bar > 
        Types for method m are incompatible
 #     Characters 67-68:
     (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('c * 'bar)>)> as 'bar);;
      ^
 Error: This expression has type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
        but an expression was expected of type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
        Types for method m are incompatible
 #   Characters 66-67:
     (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('b * 'bar)>)> as 'bar);;
      ^
 Error: This expression has type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
        but an expression was expected of type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
        Types for method m are incompatible
 #   Characters 51-52:
     (x : <m : 'b. 'b * ('b * <m:'c. 'c * 'bar> as 'bar)>);;
      ^
 Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
        but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
        Types for method m are incompatible
 #     Characters 14-115:
   ....(x : <m : 'a. 'a -> ('a * <m:'c. 'c -> 'bar> as 'bar)>
          :> <m : 'a. 'a -> ('a * 'foo)> as 'foo)..
-Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) >
+Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
        is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f 
 #       Characters 88-150:
   = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end
+         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
        is not included in
          sig
-           val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit
+           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
          end
        Values do not match:
-         val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit
+         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
        is not included in
-         val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit
+         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
 #     Characters 78-132:
   = struct type t = <m : 'a. 'a * ('a * 'foo)> as 'foo end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end
+         sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
        is not included in
-         sig type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > end
+         sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
        Type declarations do not match:
-         type t = < m : 'b. 'b * ('b * 'a) > as 'a
+         type t = < m : 'a. 'a * ('a * 'b) > as 'b
        is not included in
-         type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
 #     module M : sig type 'a t type u = < m : 'a. 'a t > end
 #   module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
 #     module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
 #         val f :
-  (< m : 'b. 'b -> (< m : 'b. 'b -> 'c * <  > > as 'c) * < .. >; .. > as 'a) ->
-  'a -> bool = <fun>
+  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
+  'b -> bool = <fun>
 #         type t = [ `A | `B ]
 # type v = private [> t ]
 # - : t -> v = <fun>
@@ -514,12 +514,12 @@ Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
          < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
 #     val f2 :
   < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
-  < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > = <fun>
+  < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun>
 #     Characters 13-107:
   ..(x : <m:'a. (<p:<a:int;b:int>;..> as 'a) -> int>
       :> <m:'b. (<p:<a:int>;..> as 'b) -> int>)..
 Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
-       is not a subtype of < m : 'a. (< p : < a : int >; .. > as 'a) -> int > 
+       is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
 # Characters 11-55:
   let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);;
              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -528,18 +528,47 @@ Error: Type < p : < a : int; b : int >; .. > is not a subtype of
 The second object type has no method b
 #   val f5 :
   < m : 'a. [< `A of < p : int > ] as 'a > ->
-  < m : 'a. [< `A of <  > ] as 'a > = <fun>
+  < m : 'b. [< `A of <  > ] as 'b > = <fun>
 #   Characters 13-83:
     (x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
-         < m : 'a. [< `A of < p : int > ] as 'a > 
+         < m : 'b. [< `A of < p : int > ] as 'b > 
+#     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
+# Characters 9-16:
+  fun x -> (f x)#m;; (* Warning 18 *)
+           ^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
+# Characters 9-20:
+  fun x -> (f (x,x))#m;; (* Warning 18 *)
+           ^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
+# Characters 9-20:
+  fun x -> (f x).(0)#m;; (* Warning 18 *)
+           ^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+- : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
 #     class c : object method id : 'a -> 'a end
 # type u = c option
 # val just : 'a option -> 'a = <fun>
-# val f : c -> 'a -> 'a = <fun>
-#     val g : c -> 'a -> 'a = <fun>
+# Characters 42-62:
+  let f x = let l = [Some x; (None : u)] in (just(List.hd l))#id;;
+                                            ^^^^^^^^^^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+val f : c -> 'a -> 'a = <fun>
+#     Characters 101-112:
+    let x = List.hd [Some x; none] in (just x)#id;;
+                                      ^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+val g : c -> 'a -> 'a = <fun>
 #     val h : < id : 'a; .. > -> 'a = <fun>
+#     type 'a u = c option
+# val just : 'a option -> 'a = <fun>
+# val f : c -> 'a -> 'a = <fun>
 #       val f : 'a -> int = <fun>
 val g : 'a -> int = <fun>
 # type 'a t = Leaf of 'a | Node of ('a * 'a) t
@@ -548,7 +577,7 @@ val g : 'a -> int = <fun>
     function Leaf _ -> 1 | Node x -> 1 + d x
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'a t -> int which is less general than
-         'b. 'b t -> int
+         'a0. 'a0 t -> int
 #   Characters 34-78:
     function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -558,12 +587,12 @@ Error: This definition has type int t -> int which is less general than
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'a t -> 'a which is less general than
-         'b. 'b t -> 'a
+         'a0. 'a0 t -> 'a
 #   Characters 38-78:
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a. 'a t -> 'a which is less general than
-         'b 'c. 'c t -> 'b
+Error: This definition has type 'b. 'b t -> 'b which is less general than
+         'b 'a. 'a t -> 'b
 #   val r : 'a list * '_b list ref = ([], {contents = []})
 val q : unit -> 'a list * '_b list ref = <fun>
 # val f : 'a -> 'a = <fun>
@@ -591,9 +620,19 @@ val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun>
 val l : t = {f = <lazy>}
 #     type t = { f : 'a. 'a -> unit; }
 # - : t = {f = <fun>}
-# Characters 3-16:
-  {f=fun ?x y -> y};; (* fail *)
-     ^^^^^^^^^^^^^
+# Characters 19-20:
+  let f ?x y = y in {f};; (* fail *)
+                     ^
 Error: This field value has type unit -> unit which is less general than
          'a. 'a -> unit
+#               module Polux :
+  sig
+    type 'par t = 'par
+    val ident : 'a -> 'a
+    class alias : object method alias : 'a t -> 'a end
+    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
+  end
+#       Exception: Pervasives.Exit.
+#   Exception: Pervasives.Exit.
+#   Exception: Pervasives.Exit.
 # 

diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference
index 6e4fce853b069a6ee1ec1025906c54211b822d03..89d050b374c638cc352bc4ce3f324fee909f1f99 100644 (file)
--- a/testsuite/tests/typing-poly/poly.ml.reference
+++ b/testsuite/tests/typing-poly/poly.ml.reference
@@ -3,17 +3,17 @@
 # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; }
 # val f : 'a list -> 'a fold = <fun>
 # - : int = 6
-#               class ['a] ilist :
-  'a list ->
-  object ('b)
-    val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+#               class ['b] ilist :
+  'b list ->
+  object ('c)
+    val l : 'b list
+    method add : 'b -> 'c
+    method fold : f:('a -> 'b -> 'a) -> init:'a -> 'a
   end
 #         class virtual ['a] vlist :
-  object ('b)
-    method virtual add : 'a -> 'b
-    method virtual fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+  object ('c)
+    method virtual add : 'a -> 'c
+    method virtual fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #             class ilist2 :
   int list ->
@@ -25,54 +25,54 @@
 #             val ilist2 : 'a list -> 'a vlist = <fun>
 #             class ['a] ilist3 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #               class ['a] ilist4 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #                 class ['a] ilist5 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
-    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #                 class ['a] ilist6 :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method add : 'a -> 'b
-    method fold : f:('c -> 'a -> 'c) -> init:'c -> 'c
-    method fold2 : f:('d -> 'a -> 'd) -> init:'d -> 'd
+    method add : 'a -> 'c
+    method fold : f:('b -> 'a -> 'b) -> init:'b -> 'b
+    method fold2 : f:('b -> 'a -> 'b) -> init:'b -> 'b
   end
 #       class virtual ['a] olist :
-  object method virtual fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+  object method virtual fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
 #         class ['a] onil :
-  object method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b end
+  object method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end
 #             class ['a] ocons :
   hd:'a ->
   tl:'a olist ->
   object
     val hd : 'a
     val tl : 'a olist
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
 #               class ['a] ostream :
   hd:'a ->
   tl:'a ostream ->
   object
     val hd : 'a
-    val tl : 'a ostream
+    val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c >
     method empty : bool
-    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
+    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
 #                   class ['a] ostream1 :
   hd:'a ->
@@ -119,13 +119,13 @@ val p1 : point = <obj>
 val cp : color_point = <obj>
 val c : circle = <obj>
 val d : float = 11.4536240470737098
-#   val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
+#   val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun>
 #   Characters 41-42:
   let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >)
                                            ^
-Error: This expression has type < m : 'a. 'a -> 'a list >
-       but an expression was expected of type < m : 'a. 'a -> 'b >
-       The universal variable 'a would escape its scope
+Error: This expression has type < m : 'b. 'b -> 'b list >
+       but an expression was expected of type < m : 'b. 'b -> 'c >
+       The universal variable 'b would escape its scope
 #           class id : object method id : 'a -> 'a end
 #         class type id_spec = object method id : 'a -> 'a end
 #       class id_impl : object method id : 'a -> 'a end
@@ -142,13 +142,13 @@ Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a
 #           Characters 80-85:
     method id _ = x
               ^^^^^
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
 #                 Characters 92-159:
   ............x =
       match r with
         None -> r <- Some x; x
       | Some y -> y
-Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b
+Error: This method has type 'b -> 'b which is less general than 'a. 'a -> 'a
 #         class c : object method m : 'a -> 'b -> 'a end
 #     val f1 : id -> int * bool = <fun>
 #   val f2 : id -> int * bool = <fun>
@@ -167,16 +167,16 @@ Error: This expression has type bool but an expression was expected of type
 Error: The type abbreviation foo is cyclic
 #     class ['a] bar : 'a -> object  end
 #   type 'a foo = 'a foo bar
-#   - : (< m : 'b. 'b * 'a > as 'a) -> 'c * 'a = <fun>
-# - : (< m : 'b. 'a * 'b list > as 'a) -> 'a * 'c list = <fun>
+#   - : (< m : 'a. 'a * 'b > as 'b) -> 'c * 'b = <fun>
+# - : (< m : 'a. 'b * 'a list > as 'b) -> 'b * 'c list = <fun>
 # val f :
   (< m : 'b. 'a * (< n : 'b; .. > as 'b) > as 'a) ->
   'a * (< n : 'c; .. > as 'c) = <fun>
 # - : (< p : 'b. < m : 'b; n : 'a; .. > as 'b > as 'a) ->
     (< m : 'c; n : 'a; .. > as 'c)
 = <fun>
-# - : (< m : 'b. 'b * < p : 'd. 'd * 'c * 'a > as 'c > as 'a) ->
-    ('f * < p : 'g. 'g * 'e * 'a > as 'e)
+# - : (< m : 'a. 'a * < p : 'b. 'b * 'd * 'c > as 'd > as 'c) ->
+    ('f * < p : 'b. 'b * 'e * 'c > as 'e)
 = <fun>
 #   - : < m : 'a. < p : 'a; .. > as 'b > -> 'b = <fun>
 #   type sum = T of < id : 'a. 'a -> 'a >
@@ -184,14 +184,14 @@ Error: The type abbreviation foo is cyclic
 #   type record = { r : < id : 'a. 'a -> 'a >; }
 # - : record -> 'a -> 'a = <fun>
 # - : record -> 'a -> 'a = <fun>
-#       class myself : object ('a) method self : 'b -> 'a end
+#       class myself : object ('b) method self : 'a -> 'b end
 #                       class number :
-  object ('a)
+  object ('b)
     val num : int
     method num : int
-    method prev : 'a
-    method succ : 'a
-    method switch : zero:(unit -> 'b) -> prev:('a -> 'b) -> 'b
+    method prev : 'b
+    method succ : 'b
+    method switch : zero:(unit -> 'a) -> prev:('b -> 'a) -> 'a
   end
 #     val id : 'a -> 'a = <fun>
 #       class c : object method id : 'a -> 'a end
@@ -201,14 +201,14 @@ Error: The type abbreviation foo is cyclic
     val mutable count : int
     method count : int
     method id : 'a -> 'a
-    method old : 'b -> 'b
+    method old : 'a -> 'a
   end
 #             class ['a] olist :
   'a list ->
-  object ('b)
+  object ('c)
     val l : 'a list
-    method cons : 'a -> 'b
-    method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
+    method cons : 'a -> 'c
+    method fold : f:('a -> 'b -> 'b) -> init:'b -> 'b
   end
 #   val sum : int #olist -> int = <fun>
 #   val count : 'a #olist -> int = <fun>
@@ -229,16 +229,16 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end
 # Characters 17-25:
   let bad = {bad = ref None};;
                    ^^^^^^^^
-Error: This field value has type 'a option ref which is less general than
-         'b. 'b option ref
+Error: This field value has type 'b option ref which is less general than
+         'a. 'a option ref
 # type bad2 = { mutable bad2 : 'a. 'a option ref option; }
 # val bad2 : bad2 = {bad2 = None}
 # Characters 13-28:
   bad2.bad2 <- Some (ref None);;
                ^^^^^^^^^^^^^^^
-Error: This field value has type 'a option ref option
-       which is less general than 'b. 'b option ref option
-#       val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = <fun>
+Error: This field value has type 'b option ref option
+       which is less general than 'a. 'a option ref option
+#       val f : < m : 'a. < p : 'a * 'c > as 'c > -> 'b -> unit = <fun>
 # val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = <fun>
 #       type 'a t = [ `A of 'a ]
 #       class c : object method m : ([> 'a t ] as 'a) -> unit end
@@ -248,10 +248,10 @@ Error: This field value has type 'a option ref option
 #           Characters 145-166:
   object method virtual visit : 'a.('a visitor -> 'a) end;;
                                 ^^^^^^^^^^^^^^^^^^^^^
-Error: This type scheme cannot quantify 'a :
-it escapes this scope.
+Error: The universal type variable 'a cannot be generalized:
+       it escapes its scope.
 #                 type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a >
-type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b >
+type 'b alist = < visit : 'a. ('a, 'b) list_visitor -> 'a >
 class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end
 type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; }
 #     Characters 20-25:
@@ -264,7 +264,7 @@ type t = [ `A of t a ]
   type ('a,'b) t constraint 'a = 'b and ('a,'b) u = ('a,'b) t;;
                                                     ^^^^^^^^^
 Error: Constraints are not satisfied in this type.
-Type ('a, 'b) t should be an instance of ('c, 'c) t
+       Type ('a, 'b) t should be an instance of ('c, 'c) t
 #     type 'a t = 'a
 and u = int t
 #     type 'a t constraint 'a = int
@@ -272,7 +272,7 @@ and u = int t
   type 'a u = 'a and 'a v = 'a u t;;
                             ^^^^^^
 Error: Constraints are not satisfied in this type.
-Type 'a u t should be an instance of int t
+       Type 'a u t should be an instance of int t
 # type 'a u = 'a constraint 'a = int
 and 'a v = 'a u t constraint 'a = int
 #     type g = int
@@ -281,7 +281,7 @@ and 'a v = 'a u t constraint 'a = int
   type 'a u = 'a and 'a v = 'a u t;;
                             ^^^^^^
 Error: Constraints are not satisfied in this type.
-Type 'a u t should be an instance of g t
+       Type 'a u t should be an instance of g t
 # type 'a u = 'a constraint 'a = g
 and 'a v = 'a u t constraint 'a = int
 #     Characters 38-58:
@@ -333,10 +333,10 @@ Warning 11: this match case is unused.
   type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] 
        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Constraints are not satisfied in this type.
-Type
-([> `B of 'a ], 'a) b as 'a
-should be an instance of
-(('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
+       Type
+       ([> `B of 'a ], 'a) b as 'a
+       should be an instance of
+       (('b, [> `A of 'b ] as 'c) a as 'b, 'c) b
 #     *                           class type ['a, 'b] a =
   object
     constraint 'a = < as_a : ('a, 'b) a as 'c; b : 'b; .. >
@@ -395,9 +395,9 @@ Error: This object is expected to have type < x : int; .. >
 #         Characters 76-77:
     (x : <m : 'a. 'a * (<m:'b. 'a * <m:'c. 'c * 'bar> > as 'bar) >);;
      ^
-Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
+Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b
        but an expression was expected of type
-         < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) >
+         < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) >
        Types for method m are incompatible
 #         Characters 176-177:
   let f (x : foo') = (x : bar');;
@@ -405,70 +405,70 @@ Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a
 Error: This expression has type foo' = < m : 'a. 'a * 'a foo >
        but an expression was expected of type bar' = < m : 'a. 'a * 'a bar >
        Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > 
+         'a bar = < m : 'a * < m : 'c. 'c * 'a bar > > 
        Type 'a foo = < m : 'a * 'a foo > is not compatible with type
-         < m : 'b. 'b * 'a bar > 
+         < m : 'c. 'c * 'a bar > 
        Types for method m are incompatible
 #     Characters 67-68:
     (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('c * 'bar)>)> as 'bar);;
      ^
 Error: This expression has type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
        but an expression was expected of type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('c * 'd) >) > as 'd
        Types for method m are incompatible
 #   Characters 66-67:
     (x : <m : 'b. 'b * ('b * <m : 'c. 'c * ('b * 'bar)>)> as 'bar);;
      ^
 Error: This expression has type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
        but an expression was expected of type
-         < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd
+         < m : 'b. 'b * ('b * < m : 'c. 'c * ('b * 'd) >) > as 'd
        Types for method m are incompatible
 #   Characters 51-52:
     (x : <m : 'b. 'b * ('b * <m:'c. 'c * 'bar> as 'bar)>);;
      ^
 Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a
        but an expression was expected of type
-         < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) >
+         < m : 'b. 'b * ('b * < m : 'c. 'c * 'd > as 'd) >
        Types for method m are incompatible
 #     Characters 14-115:
   ....(x : <m : 'a. 'a -> ('a * <m:'c. 'c -> 'bar> as 'bar)>
          :> <m : 'a. 'a -> ('a * 'foo)> as 'foo)..
-Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) >
+Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) >
        is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f 
 #       Characters 88-150:
   = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end
+         sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end
        is not included in
          sig
-           val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit
+           val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
          end
        Values do not match:
-         val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit
+         val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit
        is not included in
-         val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit
+         val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit
 #     Characters 78-132:
   = struct type t = <m : 'a. 'a * ('a * 'foo)> as 'foo end;;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end
+         sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end
        is not included in
-         sig type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > end
+         sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end
        Type declarations do not match:
-         type t = < m : 'b. 'b * ('b * 'a) > as 'a
+         type t = < m : 'a. 'a * ('a * 'b) > as 'b
        is not included in
-         type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) >
+         type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) >
 #     module M : sig type 'a t type u = < m : 'a. 'a t > end
 #   module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
 #     module M : sig type 'a t val f : < m : 'a. 'a t > -> int end
 #         val f :
-  (< m : 'b. 'b -> (< m : 'b. 'b -> 'c * <  > > as 'c) * < .. >; .. > as 'a) ->
-  'a -> bool = <fun>
+  (< m : 'a. 'a -> (< m : 'a. 'a -> 'c * <  > > as 'c) * < .. >; .. > as 'b) ->
+  'b -> bool = <fun>
 #         type t = [ `A | `B ]
 # type v = private [> t ]
 # - : t -> v = <fun>
@@ -497,12 +497,12 @@ Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of
          < m : 'b. (< p : int; q : int; .. > as 'b) -> int > 
 #     val f2 :
   < m : 'a. (< p : < a : int >; .. > as 'a) -> int > ->
-  < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > = <fun>
+  < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun>
 #     Characters 13-107:
   ..(x : <m:'a. (<p:<a:int;b:int>;..> as 'a) -> int>
       :> <m:'b. (<p:<a:int>;..> as 'b) -> int>)..
 Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int >
-       is not a subtype of < m : 'a. (< p : < a : int >; .. > as 'a) -> int > 
+       is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > 
 # Characters 11-55:
   let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);;
              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -511,18 +511,27 @@ Error: Type < p : < a : int; b : int >; .. > is not a subtype of
 The second object type has no method b
 #   val f5 :
   < m : 'a. [< `A of < p : int > ] as 'a > ->
-  < m : 'a. [< `A of <  > ] as 'a > = <fun>
+  < m : 'b. [< `A of <  > ] as 'b > = <fun>
 #   Characters 13-83:
     (x : <m:'a. [< `A of < > ] as 'a> :> <m:'a. [< `A of <p:int> ] as 'a>);;
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Type < m : 'a. [< `A of <  > ] as 'a > is not a subtype of
-         < m : 'a. [< `A of < p : int > ] as 'a > 
+         < m : 'b. [< `A of < p : int > ] as 'b > 
+#     val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun>
+# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+# val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun>
+# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
+# val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > array = <fun>
+# - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun>
 #     class c : object method id : 'a -> 'a end
 # type u = c option
 # val just : 'a option -> 'a = <fun>
 # val f : c -> 'a -> 'a = <fun>
 #     val g : c -> 'a -> 'a = <fun>
 #     val h : < id : 'a; .. > -> 'a = <fun>
+#     type 'a u = c option
+# val just : 'a option -> 'a = <fun>
+# val f : c -> 'a -> 'a = <fun>
 #       val f : 'a -> int = <fun>
 val g : 'a -> int = <fun>
 # type 'a t = Leaf of 'a | Node of ('a * 'a) t
@@ -531,7 +540,7 @@ val g : 'a -> int = <fun>
     function Leaf _ -> 1 | Node x -> 1 + d x
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'a t -> int which is less general than
-         'b. 'b t -> int
+         'a0. 'a0 t -> int
 #   Characters 34-78:
     function Leaf x -> x | Node x -> 1 + depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
@@ -541,12 +550,12 @@ Error: This definition has type int t -> int which is less general than
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This definition has type 'a t -> 'a which is less general than
-         'b. 'b t -> 'a
+         'a0. 'a0 t -> 'a
 #   Characters 38-78:
     function Leaf x -> x | Node x -> depth x;; (* fails *)
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: This definition has type 'a. 'a t -> 'a which is less general than
-         'b 'c. 'c t -> 'b
+Error: This definition has type 'b. 'b t -> 'b which is less general than
+         'b 'a. 'a t -> 'b
 #   val r : 'a list * '_b list ref = ([], {contents = []})
 val q : unit -> 'a list * '_b list ref = <fun>
 # val f : 'a -> 'a = <fun>
@@ -574,9 +583,19 @@ val transf_alist : (int -> t) -> ('a * t) list -> ('a * t) list = <fun>
 val l : t = {f = <lazy>}
 #     type t = { f : 'a. 'a -> unit; }
 # - : t = {f = <fun>}
-# Characters 3-16:
-  {f=fun ?x y -> y};; (* fail *)
-     ^^^^^^^^^^^^^
+# Characters 19-20:
+  let f ?x y = y in {f};; (* fail *)
+                     ^
 Error: This field value has type unit -> unit which is less general than
          'a. 'a -> unit
+#               module Polux :
+  sig
+    type 'par t = 'par
+    val ident : 'a -> 'a
+    class alias : object method alias : 'a t -> 'a end
+    val f : < m : 'a. 'a t > -> < m : 'a. 'a >
+  end
+#       Exception: Pervasives.Exit.
+#   Exception: Pervasives.Exit.
+#   Exception: Pervasives.Exit.
 # 

diff --git a/testsuite/tests/typing-polyvariants-bugs-2/Makefile b/testsuite/tests/typing-polyvariants-bugs-2/Makefile
index 3f01800ffa69fe417df0e255f6b235c3f489287e..9ecfbe381f50411a455c58bd2aea751adf44b543 100644 (file)
--- a/testsuite/tests/typing-polyvariants-bugs-2/Makefile
+++ b/testsuite/tests/typing-polyvariants-bugs-2/Makefile
@@ -1,7 +1,8 @@
+BASEDIR=../..
 default:
        @printf " ... testing 'pr3918':"
        @($(OCAMLC) -c pr3918a.mli && $(OCAMLC) -c pr3918b.mli && $(OCAMLC) -c pr3918c.ml && echo " => passed") || echo " => failed"
 
 clean: defaultclean
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-polyvariants-bugs/Makefile b/testsuite/tests/typing-polyvariants-bugs/Makefile
index 9375ddba6ff7656dc858ab6f45188321ab5a3ed4..1b07f20605758cb646e42f113ad86790572adbb7 100644 (file)
--- a/testsuite/tests/typing-polyvariants-bugs/Makefile
+++ b/testsuite/tests/typing-polyvariants-bugs/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-private-bugs/Makefile b/testsuite/tests/typing-private-bugs/Makefile
index 9375ddba6ff7656dc858ab6f45188321ab5a3ed4..1b07f20605758cb646e42f113ad86790572adbb7 100644 (file)
--- a/testsuite/tests/typing-private-bugs/Makefile
+++ b/testsuite/tests/typing-private-bugs/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-private-bugs/pr5469_ok.ml b/testsuite/tests/typing-private-bugs/pr5469_ok.ml
new file mode 100644 (file)
index 0000000..74d3554
--- /dev/null
+++ b/testsuite/tests/typing-private-bugs/pr5469_ok.ml
@@ -0,0 +1,7 @@
+module M (T:sig type t end)
+ = struct type t = private { t : T.t } end
+module P
+ = struct
+       module T = struct type t end
+       module R = M(T)
+ end

diff --git a/testsuite/tests/typing-private/.svnignore b/testsuite/tests/typing-private/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/typing-private/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/typing-private/Makefile b/testsuite/tests/typing-private/Makefile
index 9add15574f085c06eee00ba0f8fcc28747d1a387..5f42b70577daa3d318645ab760281a30482bdb48 100644 (file)
--- a/testsuite/tests/typing-private/Makefile
+++ b/testsuite/tests/typing-private/Makefile
@@ -1,3 +1,4 @@
-include ../../makefiles/Makefile.toplevel
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
 

diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference
index f5b85b2055c21409ee9946d9d02f0b0eb16b4998..27cf983976915a89d0f5f63d72edaccbe2675839 100644 (file)
--- a/testsuite/tests/typing-private/private.ml.reference
+++ b/testsuite/tests/typing-private/private.ml.reference
@@ -7,7 +7,7 @@
 Error: This expression has type F0.t but an expression was expected of type
          Foobar.t
 #   module F : sig type t = Foobar.t end
-#   val f : F.t -> F.t = <fun>
+#   val f : F.t -> Foobar.t = <fun>
 #   module M : sig type t = < m : int > end
 # module M1 : sig type t = private < m : int; .. > end
 # module M2 : sig type t = private < m : int; .. > end
@@ -73,7 +73,7 @@ Error: Signature mismatch:
     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
        Modules do not match:
-         sig type t = int val f : t -> t end
+         sig type t = int val f : int -> t end
        is not included in
          sig type t = private Foobar.t val f : int -> t end
        Type declarations do not match:

diff --git a/testsuite/tests/typing-recmod/Makefile b/testsuite/tests/typing-recmod/Makefile
index 9375ddba6ff7656dc858ab6f45188321ab5a3ed4..1b07f20605758cb646e42f113ad86790572adbb7 100644 (file)
--- a/testsuite/tests/typing-recmod/Makefile
+++ b/testsuite/tests/typing-recmod/Makefile
@@ -1,2 +1,3 @@
-include ../../makefiles/Makefile.okbad
-include ../../makefiles/Makefile.common
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.okbad
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/typing-signatures/Makefile b/testsuite/tests/typing-signatures/Makefile
new file mode 100644 (file)
index 0000000..5f42b70
--- /dev/null
+++ b/testsuite/tests/typing-signatures/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+

diff --git a/testsuite/tests/typing-signatures/els.ml b/testsuite/tests/typing-signatures/els.ml
new file mode 100644 (file)
index 0000000..f3c9c79
--- /dev/null
+++ b/testsuite/tests/typing-signatures/els.ml
@@ -0,0 +1,92 @@
+(* Adapted from: An Expressive Language of Signatures
+   by Norman Ramsey, Kathleen Fisher and Paul Govereau *)
+
+module type VALUE = sig
+  type value (* a Lua value *)
+  type state (* the state of a Lua interpreter *)
+  type usert (* a user-defined value *)
+end;;
+
+module type CORE0 = sig
+  module V : VALUE
+  val setglobal : V.state -> string -> V.value -> unit
+  (* five more functions common to core and evaluator *)
+end;;
+
+module type CORE = sig
+  include CORE0
+  val apply : V.value -> V.state -> V.value list -> V.value
+  (* apply function f in state s to list of args *)
+end;;
+
+module type AST = sig
+  module Value : VALUE
+  type chunk
+  type program
+  val get_value : chunk -> Value.value
+end;;
+
+module type EVALUATOR = sig
+  module Value : VALUE
+  module Ast : (AST with module Value := Value)
+  type state = Value.state
+  type value = Value.value
+  exception Error of string
+  val compile : Ast.program -> string
+  include CORE0 with module V := Value
+end;;
+
+module type PARSER = sig
+  type chunk
+  val parse : string -> chunk
+end;;
+
+module type INTERP = sig
+  include EVALUATOR
+  module Parser : PARSER with type chunk = Ast.chunk
+  val dostring : state -> string -> value list
+  val mk       : unit -> state
+end;;
+
+module type USERTYPE = sig
+  type t
+  val eq       : t -> t -> bool
+  val to_string : t -> string
+end;;
+
+module type TYPEVIEW = sig
+  type combined
+  type t
+  val map : (combined -> t) * (t -> combined)
+end;;
+
+module type COMBINED_COMMON = sig
+  module T : sig type t end
+  module TV1 : TYPEVIEW with type combined := T.t
+  module TV2 : TYPEVIEW with type combined := T.t
+end;;
+
+module type COMBINED_TYPE = sig
+  module T : USERTYPE
+  include COMBINED_COMMON with module T := T
+end;;
+
+module type BARECODE = sig
+  type state
+  val init : state -> unit
+end;;
+
+module USERCODE(X : TYPEVIEW) = struct
+  module type F =
+      functor (C : CORE with type V.usert = X.combined) ->
+        BARECODE with type state := C.V.state
+end;;
+
+module Weapon = struct type t end;;
+
+module type WEAPON_LIB = sig
+  type t = Weapon.t
+  module T : USERTYPE with type t = t
+  module Make :
+    functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F
+end;;

diff --git a/testsuite/tests/typing-signatures/els.ml.reference b/testsuite/tests/typing-signatures/els.ml.reference
new file mode 100644 (file)
index 0000000..91b4a32
--- /dev/null
+++ b/testsuite/tests/typing-signatures/els.ml.reference
@@ -0,0 +1,93 @@
+
+# *             module type VALUE = sig type value type state type usert end
+#           module type CORE0 =
+  sig
+    module V : VALUE
+    val setglobal : V.state -> string -> V.value -> unit
+  end
+#           module type CORE =
+  sig
+    module V : VALUE
+    val setglobal : V.state -> string -> V.value -> unit
+    val apply : V.value -> V.state -> V.value list -> V.value
+  end
+#             module type AST =
+  sig
+    module Value : VALUE
+    type chunk
+    type program
+    val get_value : chunk -> Value.value
+  end
+#                   module type EVALUATOR =
+  sig
+    module Value : VALUE
+    module Ast :
+      sig type chunk type program val get_value : chunk -> Value.value end
+    type state = Value.state
+    type value = Value.value
+    exception Error of string
+    val compile : Ast.program -> string
+    val setglobal : Value.state -> string -> Value.value -> unit
+  end
+#         module type PARSER = sig type chunk val parse : string -> chunk end
+#             module type INTERP =
+  sig
+    module Value : VALUE
+    module Ast :
+      sig type chunk type program val get_value : chunk -> Value.value end
+    type state = Value.state
+    type value = Value.value
+    exception Error of string
+    val compile : Ast.program -> string
+    val setglobal : Value.state -> string -> Value.value -> unit
+    module Parser :
+      sig type chunk = Ast.chunk val parse : string -> chunk end
+    val dostring : state -> string -> value list
+    val mk : unit -> state
+  end
+#           module type USERTYPE =
+  sig type t val eq : t -> t -> bool val to_string : t -> string end
+#           module type TYPEVIEW =
+  sig type combined type t val map : (combined -> t) * (t -> combined) end
+#           module type COMBINED_COMMON =
+  sig
+    module T : sig type t end
+    module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
+    module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
+  end
+#         module type COMBINED_TYPE =
+  sig
+    module T : USERTYPE
+    module TV1 : sig type t val map : (T.t -> t) * (t -> T.t) end
+    module TV2 : sig type t val map : (T.t -> t) * (t -> T.t) end
+  end
+#         module type BARECODE = sig type state val init : state -> unit end
+#           module USERCODE :
+  functor (X : TYPEVIEW) ->
+    sig
+      module type F =
+        functor
+          (C : sig
+                 module V :
+                   sig type value type state type usert = X.combined end
+                 val setglobal : V.state -> string -> V.value -> unit
+                 val apply : V.value -> V.state -> V.value list -> V.value
+               end) ->
+          sig val init : C.V.state -> unit end
+    end
+#   module Weapon : sig type t end
+#             module type WEAPON_LIB =
+  sig
+    type t = Weapon.t
+    module T :
+      sig type t = t val eq : t -> t -> bool val to_string : t -> string end
+    module Make :
+      functor
+        (TV : sig
+                type combined
+                type t = t
+                val map : (combined -> t) * (t -> combined)
+              end) ->
+        USERCODE(TV).F
+  end
+# 

diff --git a/testsuite/tests/typing-sigsubst/Makefile b/testsuite/tests/typing-sigsubst/Makefile
new file mode 100644 (file)
index 0000000..5f42b70
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/Makefile
@@ -0,0 +1,4 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+

diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml b/testsuite/tests/typing-sigsubst/sigsubst.ml
new file mode 100644 (file)
index 0000000..4cb22fa
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/sigsubst.ml
@@ -0,0 +1,37 @@
+module type Printable = sig
+  type t
+  val print : Format.formatter -> t -> unit
+end;;
+module type Comparable = sig
+  type t
+  val compare : t -> t -> int
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t = t
+end;;
+module type PrintableComparable = sig
+  type t
+  include Printable with type t := t
+  include Comparable with type t := t
+end;;
+module type PrintableComparable = sig
+  include Printable
+  include Comparable with type t := t
+end;;
+module type ComparableInt = Comparable with type t := int;;
+module type S = sig type t val f : t -> t end;;
+module type S' = S with type t := int;;
+
+module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end;;
+module type S1 = S with type 'a t := 'a list;;
+module type S2 = sig
+  type 'a dict = (string * 'a) list
+  include S with type 'a t := 'a dict
+end;;
+
+
+module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end;;
+module M = struct type exp = string type arg = int end;;
+module type S' = S with module T := M;;

diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml.reference b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference
new file mode 100644 (file)
index 0000000..3adcb82
--- /dev/null
+++ b/testsuite/tests/typing-sigsubst/sigsubst.ml.reference
@@ -0,0 +1,36 @@
+
+#       module type Printable =
+  sig type t val print : Format.formatter -> t -> unit end
+#       module type Comparable = sig type t val compare : t -> t -> int end
+#       Characters 60-94:
+    include Comparable with type t = t
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Multiple definition of the type name t.
+       Names must be unique in a given structure or signature.
+#         module type PrintableComparable =
+  sig
+    type t
+    val print : Format.formatter -> t -> unit
+    val compare : t -> t -> int
+  end
+#       module type PrintableComparable =
+  sig
+    type t
+    val print : Format.formatter -> t -> unit
+    val compare : t -> t -> int
+  end
+# module type ComparableInt = sig val compare : int -> int -> int end
+# module type S = sig type t val f : t -> t end
+# module type S' = sig val f : int -> int end
+#   module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end
+# module type S1 = sig val map : ('a -> 'b) -> 'a list -> 'b list end
+#       module type S2 =
+  sig
+    type 'a dict = (string * 'a) list
+    val map : ('a -> 'b) -> 'a dict -> 'b dict
+  end
+#       module type S =
+  sig module T : sig type exp type arg end val f : T.exp -> T.arg end
+# module M : sig type exp = string type arg = int end
+# module type S' = sig val f : M.exp -> M.arg end
+# 

diff --git a/testsuite/tests/typing-typeparam/.svnignore b/testsuite/tests/typing-typeparam/.svnignore
deleted file mode 100755 (executable)
index 4394099..0000000
--- a/testsuite/tests/typing-typeparam/.svnignore
+++ /dev/null
@@ -1,10 +0,0 @@
-#!/bin/sh
-
-svn propset svn:ignore -F - . <<EOF
-
-*.result
-*.byte
-*.native
-program
-
-EOF

diff --git a/testsuite/tests/typing-typeparam/Makefile b/testsuite/tests/typing-typeparam/Makefile
index ef9558e19e5dce2ab7d6ba0c5108550d9176666a..748631f9097a66b067a2afd9be08b8ea2835b619 100644 (file)
--- a/testsuite/tests/typing-typeparam/Makefile
+++ b/testsuite/tests/typing-typeparam/Makefile
@@ -1,6 +1,7 @@
 #MODULES=
+BASEDIR=../..
 MAIN_MODULE=newtype
 ADD_COMPFLAGS=-w a
 
-include ../../makefiles/Makefile.one
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/warnings/Makefile b/testsuite/tests/warnings/Makefile
index 1c60154ee87bc8cc1e565b2a53eaa1ad2b6f00de..12d375e4a713f9f1f55b196ad11fb95bdc1f4fd4 100644 (file)
--- a/testsuite/tests/warnings/Makefile
+++ b/testsuite/tests/warnings/Makefile
@@ -1,3 +1,4 @@
+BASEDIR=../..
 FLAGS=-w A
 EXECNAME=./program
 
@@ -5,10 +6,12 @@ run-all:
        @for file in *.ml; do \
          printf " ... testing '$$file':"; \
          $(OCAMLC) $(FLAGS) -o $(EXECNAME) $$file 2> `basename $$file ml`result; \
-         diff -q `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \
+         $(DIFF) `basename $$file ml`reference `basename $$file ml`result > /dev/null && echo " => passed" || echo " => failed"; \
        done;
 
+promote: defaultpromote
+
 clean: defaultclean
        @rm -f *.result $(EXECNAME)
 
-include ../../makefiles/Makefile.common
+include $(BASEDIR)/makefiles/Makefile.common

diff --git a/testsuite/tests/warnings/w01.reference b/testsuite/tests/warnings/w01.reference
index e04d3e1967dc9af0aa3901292fb83790e11d92d0..492ec7dc5226dc817259c664d2c4fe9997ed2de1 100644 (file)
--- a/testsuite/tests/warnings/w01.reference
+++ b/testsuite/tests/warnings/w01.reference
@@ -1,7 +1,5 @@
 File "w01.ml", line 4, characters 12-14:
 Warning 2: this is not the end of a comment.
-File "w01.ml", line 9, characters 8-9:
-Warning 27: unused variable y.
 File "w01.ml", line 10, characters 0-3:
 Warning 5: this function application is partial,
 maybe some arguments are missing.
@@ -11,5 +9,7 @@ Here is an example of a value that is not matched:
 0
 File "w01.ml", line 25, characters 0-1:
 Warning 10: this expression should have type unit.
+File "w01.ml", line 9, characters 8-9:
+Warning 27: unused variable y.
 File "w01.ml", line 32, characters 2-3:
 Warning 11: this match case is unused.

diff --git a/tools/.cvsignore b/tools/.cvsignore
deleted file mode 100644 (file)
index cf3c695..0000000
--- a/tools/.cvsignore
+++ /dev/null
@@ -1,25 +0,0 @@
-ocamldep
-ocamldep.opt
-ocamldep.bak
-ocamlprof
-opnames.ml
-dumpobj
-dumpapprox
-objinfo
-cvt_emit
-cvt_emit.bak
-cvt_emit.ml
-ocamlcp
-ocamlmktop
-primreq
-ocamldumpobj
-keywords
-lexer299.ml
-ocaml299to3
-ocamlmklib
-ocamlmklib.ml
-lexer301.ml
-scrapelabels
-addlabels
-myocamlbuild_config.ml
-objinfo_helper

diff --git a/tools/.depend b/tools/.depend
index 36c177ed430e9def03fdaec46d791171bd35934a..ecb74f69be5ff1d5d3bed319bd8d55edd71f6f05 100644 (file)
--- a/tools/.depend
+++ b/tools/.depend
@@ -1,62 +1,64 @@
-depend.cmi: ../parsing/parsetree.cmi
-profiling.cmi:
-addlabels.cmo: ../parsing/parsetree.cmi ../parsing/parse.cmi \
+depend.cmi : ../parsing/parsetree.cmi
+profiling.cmi :
+addlabels.cmo : ../parsing/parsetree.cmi ../parsing/parse.cmi \
     ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi
-addlabels.cmx: ../parsing/parsetree.cmi ../parsing/parse.cmx \
+addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \
     ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi
-cvt_emit.cmo:
-cvt_emit.cmx:
-depend.cmo: ../parsing/parsetree.cmi ../parsing/longident.cmi \
-    ../parsing/location.cmi depend.cmi
-depend.cmx: ../parsing/parsetree.cmi ../parsing/longident.cmx \
-    ../parsing/location.cmx depend.cmi
-dumpobj.cmo: ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
-    ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \
-    ../typing/ident.cmi ../bytecomp/emitcode.cmi ../utils/config.cmi \
-    ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmi \
-    ../parsing/asttypes.cmi
-dumpobj.cmx: ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \
-    ../parsing/location.cmx ../bytecomp/lambda.cmx ../bytecomp/instruct.cmx \
-    ../typing/ident.cmx ../bytecomp/emitcode.cmx ../utils/config.cmx \
-    ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmx \
-    ../parsing/asttypes.cmi
-myocamlbuild_config.cmo:
-myocamlbuild_config.cmx:
-objinfo.cmo: ../utils/misc.cmi ../utils/config.cmi ../asmcomp/cmx_format.cmi \
-    ../bytecomp/cmo_format.cmi ../asmcomp/clambda.cmi \
-    ../bytecomp/bytesections.cmi
-objinfo.cmx: ../utils/misc.cmx ../utils/config.cmx ../asmcomp/cmx_format.cmi \
-    ../bytecomp/cmo_format.cmi ../asmcomp/clambda.cmx \
-    ../bytecomp/bytesections.cmx
-ocaml299to3.cmo:
-ocaml299to3.cmx:
-ocamlcp.cmo: ../driver/main_args.cmi
-ocamlcp.cmx: ../driver/main_args.cmx
-ocamldep.cmo: ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \
+cvt_emit.cmo :
+cvt_emit.cmx :
+depend.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \
+    ../parsing/longident.cmi ../parsing/location.cmi depend.cmi
+depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \
+    ../parsing/longident.cmx ../parsing/location.cmx depend.cmi
+dumpobj.cmo : ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \
+    ../utils/misc.cmi ../parsing/location.cmi ../bytecomp/lambda.cmi \
+    ../bytecomp/instruct.cmi ../typing/ident.cmi ../bytecomp/emitcode.cmi \
+    ../utils/config.cmi ../bytecomp/cmo_format.cmi \
+    ../bytecomp/bytesections.cmi ../parsing/asttypes.cmi
+dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \
+    ../utils/misc.cmx ../parsing/location.cmx ../bytecomp/lambda.cmx \
+    ../bytecomp/instruct.cmx ../typing/ident.cmx ../bytecomp/emitcode.cmx \
+    ../utils/config.cmx ../bytecomp/cmo_format.cmi \
+    ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi
+myocamlbuild_config.cmo :
+myocamlbuild_config.cmx :
+objinfo.cmo : ../utils/misc.cmi ../utils/config.cmi \
+    ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \
+    ../asmcomp/clambda.cmi ../bytecomp/bytesections.cmi
+objinfo.cmx : ../utils/misc.cmx ../utils/config.cmx \
+    ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \
+    ../asmcomp/clambda.cmx ../bytecomp/bytesections.cmx
+ocaml299to3.cmo :
+ocaml299to3.cmx :
+ocamlcp.cmo : ../driver/main_args.cmi
+ocamlcp.cmx : ../driver/main_args.cmx
+ocamldep.cmo : ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \
     ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \
     ../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \
     ../utils/config.cmi ../utils/clflags.cmi
-ocamldep.cmx: ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \
+ocamldep.cmx : ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \
     ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \
     ../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \
     ../utils/config.cmx ../utils/clflags.cmx
-ocamlmklib.cmo: myocamlbuild_config.cmo
-ocamlmklib.cmx: myocamlbuild_config.cmx
-ocamlmktop.cmo: ../utils/ccomp.cmi
-ocamlmktop.cmx: ../utils/ccomp.cmx
-ocamlprof.cmo: ../utils/warnings.cmi ../parsing/syntaxerr.cmi \
+ocamlmklib.cmo : myocamlbuild_config.cmo
+ocamlmklib.cmx : myocamlbuild_config.cmx
+ocamlmktop.cmo : ../utils/ccomp.cmi
+ocamlmktop.cmx : ../utils/ccomp.cmx
+ocamloptp.cmo : ../driver/main_args.cmi
+ocamloptp.cmx : ../driver/main_args.cmx
+ocamlprof.cmo : ../utils/warnings.cmi ../parsing/syntaxerr.cmi \
     ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \
     ../parsing/location.cmi ../parsing/lexer.cmi ../utils/config.cmi \
     ../utils/clflags.cmi
-ocamlprof.cmx: ../utils/warnings.cmx ../parsing/syntaxerr.cmx \
+ocamlprof.cmx : ../utils/warnings.cmx ../parsing/syntaxerr.cmx \
     ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \
     ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \
     ../utils/clflags.cmx
-opnames.cmo:
-opnames.cmx:
-primreq.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi
-primreq.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi
-profiling.cmo: profiling.cmi
-profiling.cmx: profiling.cmi
-scrapelabels.cmo:
-scrapelabels.cmx:
+opnames.cmo :
+opnames.cmx :
+primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi
+primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi
+profiling.cmo : profiling.cmi
+profiling.cmx : profiling.cmi
+scrapelabels.cmo :
+scrapelabels.cmx :

diff --git a/tools/.ignore b/tools/.ignore
new file mode 100644 (file)
index 0000000..04ea00a
--- /dev/null
+++ b/tools/.ignore
@@ -0,0 +1,26 @@
+ocamldep
+ocamldep.opt
+ocamldep.bak
+ocamlprof
+opnames.ml
+dumpobj
+dumpapprox
+objinfo
+cvt_emit
+cvt_emit.bak
+cvt_emit.ml
+ocamlcp
+ocamloptp
+ocamlmktop
+primreq
+ocamldumpobj
+keywords
+lexer299.ml
+ocaml299to3
+ocamlmklib
+ocamlmklib.ml
+lexer301.ml
+scrapelabels
+addlabels
+myocamlbuild_config.ml
+objinfo_helper

diff --git a/tools/Characters b/tools/Characters
deleted file mode 100644 (file)
index fb8e686..0000000
--- a/tools/Characters
+++ /dev/null
@@ -1,16 +0,0 @@
-# Characters
-
-# $Id$
-
-# Usage:
-#    Characters n1 to n2
-#
-# Select the characters in the given interval, counting from the first
-# character of the current line, in the active window.
-#
-# Typical use is an error message of the form:
-#    File fff; Line lll; Characters yyy to zzz
-
-exit 1 if {#} ­ 3
-
-Find Ƥ!{1}:¤!`evaluate {3} - {1}` "{active}"

diff --git a/tools/DoMake b/tools/DoMake
deleted file mode 100644 (file)
index 2fce340..0000000
--- a/tools/DoMake
+++ /dev/null
@@ -1,61 +0,0 @@
-# DoMake
-
-# $Id$
-
-# Execute the output of "Make -f Makefile.Mac -f Makefile.Mac.depend"
-# or "Make -f Makefile -f Makefile.depend" if "Makefile.Mac" does not exist
-# or "Make -f <file>" if the "-f" option is given.
-
-# usage: domake [-quiet] [-f <file>]É <make arguments>
-
-set echo 0
-
-set domake_quiet 0
-set domake_files ""
-
-loop
-  if "{1}" == "-quiet"
-    set domake_quiet 1
-    shift
-  else if "{1}" == "-f"
-    set domake_files "{domake_files} -f `quote "{2}"`"
-    shift 2
-  else
-    break
-  end
-end
-
-set tempfile "{TempFolder}temp-domake-`Date -n`"
-if "`exists "{tempfile}"`"
-  set i 0
-  loop
-    break if ! "`exists "{tempfile}.{i}"`"
-    evaluate i += 1
-  end
-  set tempfile "{tempfile}.{i}"
-end
-
-if "{domake_files}" == ""
-  if "`exists Makefile.Mac`" != ""
-    set domake_main "Makefile.Mac"
-  else
-    set domake_main "Makefile"
-  end
-
-  if "`exists "{domake_main}".depend`" != ""
-    set domake_files "-f {domake_main} -f {domake_main}.depend"
-  else
-    set domake_files "-f {domake_main}"
-  end
-end
-
-if {domake_quiet}
-  echo >"{tempfile}"
-else
-  echo 'set echo 1' >"{tempfile}"
-end
-make {domake_files} {"Parameters"} >>"{tempfile}"
-
-"{tempfile}"
-
-Delete -i "{tempfile}"

diff --git a/tools/MakeDepend b/tools/MakeDepend
deleted file mode 100644 (file)
index 5693b27..0000000
--- a/tools/MakeDepend
+++ /dev/null
@@ -1,17 +0,0 @@
-# MakeDepend
-
-# $Id$
-
-
-# Usage: MakeDepend fileÉ
-
-# Generate the Make dependency rules for a set of C files.
-# The rules are printed on standard output.
-
-set echo 0
-set exit 0
-
-for i in {"parameters"}
-  mrc -c -w off -make dev:stdout "{i}" ³ dev:null ¶
-  | streamedit -e '/¶"(Å)¨0.c.o¶"/ replace // "¶""¨0".c.o¶" ¶""¨0".c.x¶""'
-end

diff --git a/tools/Makefile b/tools/Makefile
index bad14c7e50ee77e616660b36cf9887361a26c6b4..da87fa99e5b1c46cb48e8c1815161f6474fcd062 100644 (file)
--- a/tools/Makefile
+++ b/tools/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -19,3 +19,9 @@ include Makefile.shared
 ocamlmktop: ocamlmktop.tpl ../config/Makefile
        sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop
        chmod +x ocamlmktop
+
+install::
+       cp ocamlmktop $(BINDIR)
+
+clean::
+       rm -f ocamlmktop

diff --git a/tools/Makefile.nt b/tools/Makefile.nt
index b90c0c4f6662963a75aa3f43a5c1e87a9668680c..b22e35d28027b351e64f4fb74eb9a83ed1580a62 100644 (file)
--- a/tools/Makefile.nt
+++ b/tools/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -21,3 +21,9 @@ OCAMLMKTOP_IMPORTS=misc.cmo config.cmo clflags.cmo ccomp.cmo
 
 ocamlmktop: $(OCAMLMKTOP)
        $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP)
+
+install::
+       cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE)
+
+clean::
+       rm -f ocamlmktop$(EXE)

diff --git a/tools/Makefile.shared b/tools/Makefile.shared
index 32049eab1e2755b5a19830c34392813f8c976bd6..1390ac6a9df2bc7ea898241272a4268dbcfefb23 100644 (file)
--- a/tools/Makefile.shared
+++ b/tools/Makefile.shared
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #
@@ -23,7 +23,7 @@ INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \
 COMPFLAGS= -warn-error A $(INCLUDES)
 LINKFLAGS=$(INCLUDES)
 
-all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib dumpobj objinfo
+all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj objinfo
 # scrapelabels addlabels
 
 .PHONY: all
@@ -35,7 +35,7 @@ opt.opt: ocamldep.opt
 
 CAMLDEP_OBJ=depend.cmo ocamldep.cmo
 CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
-  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  warnings.cmo location.cmo longident.cmo \
   syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
 
 ocamldep: depend.cmi $(CAMLDEP_OBJ)
@@ -60,7 +60,7 @@ install::
 
 CSLPROF=ocamlprof.cmo
 CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
-  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  warnings.cmo location.cmo longident.cmo \
   syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
 
 ocamlprof: $(CSLPROF) profiling.cmo
@@ -69,16 +69,26 @@ ocamlprof: $(CSLPROF) profiling.cmo
 ocamlcp: ocamlcp.cmo
        $(CAMLC) $(LINKFLAGS) -o ocamlcp warnings.cmo main_args.cmo ocamlcp.cmo
 
+ocamloptp: ocamloptp.cmo
+       $(CAMLC) $(LINKFLAGS) -o ocamloptp warnings.cmo main_args.cmo \
+                ocamloptp.cmo
+
+opt:: profiling.cmx
+
 install::
        cp ocamlprof $(BINDIR)/ocamlprof$(EXE)
        cp ocamlcp $(BINDIR)/ocamlcp$(EXE)
+       cp ocamloptp $(BINDIR)/ocamloptp$(EXE)
        cp profiling.cmi profiling.cmo $(LIBDIR)
 
+installopt::
+       cp profiling.cmx profiling.o $(LIBDIR)
+
 clean::
-       rm -f ocamlprof ocamlcp
+       rm -f ocamlprof ocamlcp ocamloptp
 
 
-# To help building mixed-mode libraries (Caml + C)
+# To help building mixed-mode libraries (OCaml + C)
 
 ocamlmklib: myocamlbuild_config.cmo ocamlmklib.cmo
        $(CAMLC) $(LINKFLAGS) -o ocamlmklib myocamlbuild_config.cmo \
@@ -114,19 +124,11 @@ beforedepend:: ocamlmklib.ml
 clean::
        rm -f ocamlmklib.ml
 
-# To make custom toplevels (see Makefile/Makefile.nt)
-
-install::
-       cp ocamlmktop $(BINDIR)/   # no $(EXE) here, ocamlmktop is a script
-
-clean::
-       rm -f ocamlmktop
-
 
 # Converter olabl/ocaml 2.99 to ocaml 3
 
 OCAML299TO3= lexer299.cmo ocaml299to3.cmo
-LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo
+LIBRARY3= misc.cmo warnings.cmo location.cmo
 
 ocaml299to3: $(OCAML299TO3)
        $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3)
@@ -159,7 +161,7 @@ clean::
 # Insert labels following an interface file (upgrade 3.02 to 3.03)
 
 ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \
-  linenum.cmo warnings.cmo location.cmo longident.cmo \
+  warnings.cmo location.cmo longident.cmo \
   syntaxerr.cmo parser.cmo lexer.cmo parse.cmo
 
 addlabels: addlabels.cmo

diff --git a/tools/OCamlc-custom b/tools/OCamlc-custom
deleted file mode 100644 (file)
index c389974..0000000
--- a/tools/OCamlc-custom
+++ /dev/null
@@ -1,10 +0,0 @@
-# OCamlc with option -custom
-# Macintosh version
-
-set echo 0
-set -e ocamlcommands "{tempfolder}"OCaml.temp."`date -n`"
-echo >"{ocamlcommands}"
-ocamlc -custom {"parameters"}
-execute "{ocamlcommands}"
-
-delete -y "{ocamlcommands}"

diff --git a/tools/Time b/tools/Time
deleted file mode 100644 (file)
index 0a82674..0000000
--- a/tools/Time
+++ /dev/null
@@ -1,10 +0,0 @@
-# Time       # Measure execution time
-# Usage: Time command argumentsÉ
-
-set echo 0
-
-set startdate `date -n`
-{parameters}
-set enddate `date -n`
-
-echo "# Time: `evaluate {enddate} - {startdate}` s" > dev:stderr

diff --git a/tools/addlabels.ml b/tools/addlabels.ml
index 15ad6f5a1fb3c4114f83f9833395df51c35eefac..c057e72ca868193960b4b2ac80575dada08fb295 100644 (file)
--- a/tools/addlabels.ml
+++ b/tools/addlabels.ml
@@ -1,3 +1,16 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*            Jacques Garrigue, Kyoto University RIMS                  *)
+(*                                                                     *)
+(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
+(*  en Automatique and Kyoto University.  All rights reserved.         *)
+(*  This file is distributed under the terms of the Q Public License   *)
+(*  version 1.0.                                                       *)
+(*                                                                     *)
+(***********************************************************************)
+
 (* $Id$ *)
 
 open StdLabels
@@ -64,7 +77,7 @@ let rec pattern_vars pat =
       pattern_vars pat1 @ pattern_vars pat2
   | Ppat_lazy pat -> pattern_vars pat
   | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _
-  | Ppat_type _ ->
+  | Ppat_type _ | Ppat_unpack _ ->
       []
 
 let pattern_name pat =
@@ -311,7 +324,6 @@ let rec add_labels_class ~text ~classes ~values ~methods cl =
               add_labels_expr ~text ~classes ~values e;
               values
           | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> values
-          | Pcf_let _ -> values (* not in the grammar *)
         end)
   | Pcl_fun (_, opt, pat, cl) ->
       begin match opt with None -> ()

diff --git a/tools/checkstack.c b/tools/checkstack.c
index fc760945fcc09204fe907d8b8e8b718680d3fb68..9289c678cae23f381b707a308364fb540f5b9a69 100644 (file)
--- a/tools/checkstack.c
+++ b/tools/checkstack.c
@@ -1,13 +1,12 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*          Damien Doligez, projet Moscova, INRIA Rocquencourt         */
 /*                                                                     */
 /*  Copyright 2002 Institut National de Recherche en Informatique et   */
 /*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../../LICENSE.  */
+/*  under the terms of the Q Public License version 1.0.               */
 /*                                                                     */
 /***********************************************************************/
 

diff --git a/tools/cleanup-header b/tools/cleanup-header
index 6c320fb39c71329f27cccbcacfc9402852192e99..bc64f2e9213ca142a4882b1769dae31f1e2d80bd 100644 (file)
--- a/tools/cleanup-header
+++ b/tools/cleanup-header
@@ -1,4 +1,17 @@
 #!/bin/sed -f
+
+#######################################################################
+#                                                                     #
+#                                OCaml                                #
+#                                                                     #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt         #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique.  All rights reserved.  This file is distributed    #
+#  under the terms of the Q Public License version 1.0.               #
+#                                                                     #
+#######################################################################
+
 # Remove private parts from runtime include files, before installation
 # in /usr/local/lib/ocaml/caml
 

diff --git a/tools/cvt_emit.mll b/tools/cvt_emit.mll
index 3e28ae9722ec4b2964836efff3f08c63a099c69c..eabd1baf1a5d63083ec46805acdcae786e61a0f7 100644 (file)
--- a/tools/cvt_emit.mll
+++ b/tools/cvt_emit.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/tools/depend.ml b/tools/depend.ml
index 44e85702bdac6cb6189b1f7cd8098162bbf569df..948646a8230ac531989af9202bc652bef4b15fe2 100644 (file)
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -75,7 +75,7 @@ let add_type_declaration bv td =
   let rec add_tkind = function
     Ptype_abstract -> ()
   | Ptype_variant cstrs ->
-      List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs
+      List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs
   | Ptype_record lbls ->
       List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
   add_tkind td.ptype_kind
@@ -118,6 +118,7 @@ let rec add_pattern bv pat =
   | Ppat_variant(_, op) -> add_opt add_pattern bv op
   | Ppat_type (li) -> add bv li
   | Ppat_lazy p -> add_pattern bv p
+  | Ppat_unpack _ -> ()
 
 let rec add_expr bv exp =
   match exp.pexp_desc with
@@ -163,7 +164,7 @@ let rec add_expr bv exp =
   | Pexp_object (pat, fieldl) ->
       add_pattern bv pat; List.iter (add_class_field bv) fieldl
   | Pexp_newtype (_, e) -> add_expr bv e
-  | Pexp_pack (m, pt) -> add_package_type bv pt; add_module bv m
+  | Pexp_pack m -> add_module bv m
   | Pexp_open (m, e) -> addmodule bv m; add_expr bv e
 and add_pat_expr_list bv pel =
   List.iter (fun (p, e) -> add_pattern bv p; add_expr bv e) pel
@@ -228,8 +229,7 @@ and add_module bv modl =
       add_module bv mod1; add_module bv mod2
   | Pmod_constraint(modl, mty) ->
       add_module bv modl; add_modtype bv mty
-  | Pmod_unpack(e, pt) ->
-      add_package_type bv pt;
+  | Pmod_unpack(e) ->
       add_expr bv e
 
 and add_structure bv item_list =
@@ -299,7 +299,6 @@ and add_class_field bv = function
   | Pcf_virt(_, _, ty, _) -> add_type bv ty
   | Pcf_meth(_, _, _, e, _) -> add_expr bv e
   | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2
-  | Pcf_let(_, pel, _) -> add_pat_expr_list bv pel
   | Pcf_init e -> add_expr bv e
 
 and add_class_declaration bv decl =

diff --git a/tools/depend.mli b/tools/depend.mli
index a13870610b448a2561ec0bd9d63fc951cacce758..7c6d0c01d6fc0d185e90430c305b7fa7b11214d1 100644 (file)
--- a/tools/depend.mli
+++ b/tools/depend.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml
index 2a054ee684a2fa7d795fb632751dfcde2cdc6e75..ff7ff688a4da0a43dafef382eac1050d376b3a56 100644 (file)
--- a/tools/dumpobj.ml
+++ b/tools/dumpobj.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -483,8 +483,7 @@ let print_reloc (info, pos) =
 (* Print a .cmo file *)
 
 let dump_obj filename ic =
-  let buffer = String.create (String.length cmo_magic_number) in
-  really_input ic buffer 0 (String.length cmo_magic_number);
+  let buffer = Misc.input_bytes ic (String.length cmo_magic_number) in
   if buffer <> cmo_magic_number then begin
     prerr_endline "Not an object file"; exit 2
   end;
@@ -503,8 +502,7 @@ let dump_obj filename ic =
 (* Read the primitive table from an executable *)
 
 let read_primitive_table ic len =
-  let p = String.create len in
-  really_input ic p 0 len;
+  let p = Misc.input_bytes ic len in
   let rec split beg cur =
     if cur >= len then []
     else if p.[cur] = '\000' then

diff --git a/tools/lexer299.mll b/tools/lexer299.mll
index 9a244721df149d0fe773b22cfd122d01bd4dbccc..38241af0a5f1173c8bf7c5ed5e83282810934199 100644 (file)
--- a/tools/lexer299.mll
+++ b/tools/lexer299.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/tools/lexer301.mll b/tools/lexer301.mll
index daec549e7e64d14442c67277eb2561a6e12e5c40..4548de57e9480b20eff8eb2953f473dba2ab6e7b 100644 (file)
--- a/tools/lexer301.mll
+++ b/tools/lexer301.mll
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/tools/magic b/tools/magic
index 7468066e014f40aa5d031f195dccbf585e4c5f80..089f169a16b5ac52c3b7a6eaccd3ce6e2bc6f4e8 100644 (file)
--- a/tools/magic
+++ b/tools/magic
@@ -1,7 +1,7 @@
 # Here are some definitions that can be added to the /usr/share/magic
 # database so that the file(1) command recognizes OCaml compiled files.
 # Contributed by Sven Luther.
-0       string  Caml1999        Objective Caml
+0       string  Caml1999        OCaml
 >8      string  X               bytecode executable
 >8      string  I               interface data (.cmi)
 >8      string  O               bytecode object data (.cmo)

diff --git a/tools/make-package-macosx b/tools/make-package-macosx
index ebdf0eba2c9828b5b0e54576a080d6d80709ec62..222df82211835f35a3a1ccdd208fe56037596b81 100755 (executable)
--- a/tools/make-package-macosx
+++ b/tools/make-package-macosx
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #          Damien Doligez, projet Moscova, INRIA Rocquencourt           #
 #                                                                       #
@@ -30,9 +30,9 @@ cat >Description.plist <<EOF
           <key>IFPkgDescriptionDeleteWarning</key>
           <string></string>
           <key>IFPkgDescriptionDescription</key>
-          <string>The Objective Caml compiler and tools</string>
+          <string>The OCaml compiler and tools</string>
           <key>IFPkgDescriptionTitle</key>
-          <string>Objective Caml</string>
+          <string>OCaml</string>
           <key>IFPkgDescriptionVersion</key>
           <string>${VERSION}</string>
   </dict>
@@ -46,11 +46,11 @@ cat >Info.plist <<EOF
 <plist version="1.0">
 <dict>
         <key>CFBundleGetInfoString</key>
-        <string>Objective Caml ${VERSION}</string>
+        <string>OCaml ${VERSION}</string>
         <key>CFBundleIdentifier</key>
         <string>fr.inria.ocaml</string>
         <key>CFBundleName</key>
-        <string>Objective Caml</string>
+        <string>OCaml</string>
         <key>CFBundleShortVersionString</key>
         <string>${VERSION}</string>
         <key>IFMajorVersion</key>
@@ -85,7 +85,7 @@ mkdir -p resources
 
 #                                         stop here -> |
 cat >resources/ReadMe.txt <<EOF
-This package installs Objective Caml version ${VERSION}.
+This package installs OCaml version ${VERSION}.
 You need Mac OS X 10.5.x (Leopard), with the
 XCode tools installed (v3.1.1 or later), and
 optionally X11.
@@ -109,7 +109,7 @@ size=`expr $size + 8192`
 
 hdiutil create -sectors $size ocaml-rw.dmg
 name=`hdid -nomount ocaml-rw.dmg | grep Apple_HFS | cut -d ' ' -f 1`
-volname="Objective Caml ${VERSION}"
+volname="OCaml ${VERSION}"
 newfs_hfs -v "$volname" $name
 hdiutil detach $name
 

diff --git a/tools/objinfo.ml b/tools/objinfo.ml
index e9eb403135a126c42eca8aae6e4e83f0120c8767..42fa8ee9c27b93fb2d012b843f7c2040ff551f6a 100644 (file)
--- a/tools/objinfo.ml
+++ b/tools/objinfo.ml
@@ -1,13 +1,13 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*        Mehdi Dogguy, PPS laboratory, University Paris Diderot       *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.   Modifications Copyright 2010 Mehdi Dogguy,       *)
-(*  used and distributed as part of Objective Caml by permission from  *)
+(*  used and distributed as part of OCaml by permission from           *)
 (*  the author.   This file is distributed under the terms of the      *)
 (*  Q Public License version 1.0.                                      *)
 (*                                                                     *)
@@ -34,8 +34,7 @@ let input_stringlist ic len =
       else acc
     in fold 0 0 []
   in
-  let sect = String.create len in
-  let _ = really_input ic sect 0 len in
+  let sect = Misc.input_bytes ic len in
   get_string_list sect len
 
 let print_name_crc (name, crc) =
@@ -49,12 +48,13 @@ let print_cmo_infos cu =
   print_string "Interfaces imported:\n";
   List.iter print_name_crc cu.cu_imports;
   printf "Uses unsafe features: ";
-  match cu.cu_primitives with
+  (match cu.cu_primitives with
     | [] -> printf "no\n"
     | l  ->
         printf "YES\n";
         printf "Primitives declared in this module:\n";
-        List.iter print_line l
+        List.iter print_line l);
+  printf "Force link: %s\n" (if cu.cu_force_link then "YES" else "no")
 
 let rec print_approx_infos ppf = function
     Value_closure(fundesc, approx) ->
@@ -122,7 +122,17 @@ let print_cmx_infos (ui, crc) =
   let pr_funs _ fns =
     List.iter (fun arity -> printf " %d" arity) fns in
   printf "Currying functions:%a\n" pr_funs ui.ui_curry_fun;
-  printf "Apply functions:%a\n" pr_funs ui.ui_apply_fun
+  printf "Apply functions:%a\n" pr_funs ui.ui_apply_fun;
+  printf "Send functions:%a\n" pr_funs ui.ui_send_fun;
+  printf "Force link: %s\n" (if ui.ui_force_link then "YES" else "no")
+
+let print_cmxa_infos (lib : Cmx_format.library_infos) =
+  printf "Extra C object files:";
+  List.iter print_spaced_string (List.rev lib.lib_ccobjs);
+  printf "\nExtra C options:";
+  List.iter print_spaced_string lib.lib_ccopts;
+  printf "\n";
+  List.iter print_cmx_infos lib.lib_units
 
 let print_cmxs_infos header =
   List.iter
@@ -207,8 +217,7 @@ let dump_obj filename =
   printf "File %s\n" filename;
   let ic = open_in_bin filename in
   let len_magic_number = String.length cmo_magic_number in
-  let magic_number = String.create len_magic_number in
-  really_input ic magic_number 0 len_magic_number;
+  let magic_number = Misc.input_bytes ic len_magic_number in
   if magic_number = cmo_magic_number then begin
     let cu_pos = input_binary_int ic in
     seek_in ic cu_pos;
@@ -234,7 +243,7 @@ let dump_obj filename =
   end else if magic_number = cmxa_magic_number then begin
     let li = (input_value ic : library_infos) in
     close_in ic;
-    List.iter print_cmx_infos li.lib_units
+    print_cmxa_infos li
   end else begin
     let pos_trailer = in_channel_length ic - len_magic_number in
     let _ = seek_in ic pos_trailer in

diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c
index 464720c296e0fd51d18ef114b08128df48ea8d04..689cdf750e0c19ce0a23b2cac25cd85096c70d52 100644 (file)
--- a/tools/objinfo_helper.c
+++ b/tools/objinfo_helper.c
@@ -1,11 +1,11 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*        Mehdi Dogguy, PPS laboratory, University Paris Diderot       */
 /*                                                                     */
 /*  Copyright 2010 Mehdi Dogguy.  Used and distributed as part of      */
-/*  Objective Caml by permission from the author.   This file is       */
+/*  OCaml by permission from the author.   This file is                */
 /*  distributed under the terms of the Q Public License version 1.0.   */
 /***********************************************************************/
 

diff --git a/tools/ocaml-objcopy-macosx b/tools/ocaml-objcopy-macosx
index cb2f703b4d85620eb71730886a6894fef5db143b..b4584a073822c9321ece9f8ec2d2d05d4a9833ef 100755 (executable)
--- a/tools/ocaml-objcopy-macosx
+++ b/tools/ocaml-objcopy-macosx
@@ -2,7 +2,7 @@
 
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #           Damien Doligez, projet Cristal, INRIA Rocquencourt          #
 #                                                                       #

diff --git a/tools/ocaml299to3.ml b/tools/ocaml299to3.ml
index b1dca8daafcf73d46c094acbd146a5bbb15c8c65..fb66c7616c440d975501627e3e8eccf18a065630 100644 (file)
--- a/tools/ocaml299to3.ml
+++ b/tools/ocaml299to3.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Jacques Garrigue, Kyoto University RIMS                *)
 (*                                                                     *)
@@ -124,7 +124,7 @@ let _ =
     print_endline "Usage: ocaml299to3 <source file> ...";
     print_endline "Description:";
     print_endline
-      "Convert Objective Caml 2.99 O'Labl-style labels in implementation files to";
+      "Convert OCaml 2.99 O'Labl-style labels in implementation files to";
     print_endline
       "a syntax compatible with version 3. Also `fun:' labels are replaced by `f:'.";
     print_endline "Other syntactic changes are not handled.";

diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
index a86ae352fcb4b272cc35900e90b771d12519a5eb..9d8ed152d58f041de852e56cd2893af52c2938de 100644 (file)
--- a/tools/ocamlcp.ml
+++ b/tools/ocamlcp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -43,6 +43,7 @@ let incompatible o =
 
 module Options = Main_args.Make_bytecomp_options (struct
   let _a () = make_archive := true; option "-a" ()
+  let _absname = option "-absname"
   let _annot = option "-annot"
   let _c = option "-c"
   let _cc s = option_with_arg "-cc" s
@@ -73,6 +74,7 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _pp s = incompatible "-pp"
   let _principal = option "-principal"
   let _rectypes = option "-rectypes"
+  let _runtime_variant s = option_with_arg "-runtime-variant" s
   let _strict_sequence = option "-strict-sequence"
   let _thread () = option "-thread" ()
   let _vmthread () = option "-vmthread" ()
@@ -100,7 +102,7 @@ let add_profarg s =
 ;;
 
 let optlist =
-    ("-p", Arg.String add_profarg,
+    ("-P", Arg.String add_profarg,
            "[afilmt]  Profile constructs specified by argument (default fm):\n\
         \032     a  Everything\n\
         \032     f  Function calls and method calls\n\
@@ -108,6 +110,7 @@ let optlist =
         \032     l  while and for loops\n\
         \032     m  match ... with\n\
         \032     t  try ... with")
+    :: ("-p", Arg.String add_profarg, "[afilmt]  Same as option -P")
     :: Options.list
 in
 Arg.parse optlist process_file usage;

diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index d92ad488c3af000266425c761c8c62e59467ec75..46449037adbaed55da5146669cfcc9c224aa919c 100644 (file)
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -12,14 +12,14 @@
 
 (* $Id$ *)
 
-open Format
-open Location
 open Longident
 open Parsetree
 
 
 (* Print the dependencies *)
 
+type file_kind = ML | MLI;;
+
 let load_path = ref ([] : (string * string array) list)
 let ml_synonyms = ref [".ml"]
 let mli_synonyms = ref [".mli"]
@@ -27,6 +27,10 @@ let native_only = ref false
 let force_slash = ref false
 let error_occurred = ref false
 let raw_dependencies = ref false
+let sort_files = ref false
+let all_dependencies = ref false
+let one_line = ref false
+let files = ref []
 
 (* Fix path to use '/' as directory separator instead of '\'.
    Only under Windows. *)
@@ -46,17 +50,18 @@ let add_to_load_path dir =
     let contents = Sys.readdir dir in
     load_path := !load_path @ [dir, contents]
   with Sys_error msg ->
-    fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
+    Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
     error_occurred := true
 
 let add_to_synonym_list synonyms suffix =
   if (String.length suffix) > 1 && suffix.[0] = '.' then
     synonyms := suffix :: !synonyms
   else begin
-    fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
+    Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
     error_occurred := true
   end
 
+(* Find file 'name' (capitalized) in search path *)
 let find_file name =
   let uname = String.uncapitalize name in
   let rec find_in_array a pos =
@@ -77,24 +82,51 @@ let rec find_file_in_list = function
   [] -> raise Not_found
 | x :: rem -> try find_file x with Not_found -> find_file_in_list rem
 
-let find_dependency modname (byt_deps, opt_deps) =
+
+let find_dependency target_kind modname (byt_deps, opt_deps) =
   try
     let candidates = List.map ((^) modname) !mli_synonyms in
     let filename = find_file_in_list candidates in
     let basename = Filename.chop_extension filename in
-    let optname =
-      if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms
-      then basename ^ ".cmx"
-      else basename ^ ".cmi" in
-    ((basename ^ ".cmi") :: byt_deps, optname :: opt_deps)
+    let cmi_file = basename ^ ".cmi" in
+    let ml_exists =
+      List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in
+    let new_opt_dep =
+      if !all_dependencies then
+        match target_kind with
+        | MLI -> [ cmi_file ]
+        | ML  ->
+          cmi_file :: (if ml_exists then [ basename ^ ".cmx"] else [])
+      else
+        (* this is a make-specific hack that makes .cmx to be a 'proxy'
+           target that would force the dependency on .cmi via transitivity *)
+        if ml_exists
+        then [ basename ^ ".cmx" ]
+        else [ cmi_file ]
+    in
+    ( cmi_file :: byt_deps, new_opt_dep @ opt_deps)
   with Not_found ->
   try
+    (* "just .ml" case *)
     let candidates = List.map ((^) modname) !ml_synonyms in
     let filename = find_file_in_list candidates in
     let basename = Filename.chop_extension filename in
-    let bytename =
-      basename ^ (if !native_only then ".cmx" else ".cmo") in
-    (bytename :: byt_deps, (basename ^ ".cmx") :: opt_deps)
+    let bytenames =
+      if !all_dependencies then
+        match target_kind with
+        | MLI -> [basename ^ ".cmi"]
+        | ML  -> [basename ^ ".cmi";]
+      else
+        (* again, make-specific hack *)
+        [basename ^ (if !native_only then ".cmx" else ".cmo")] in
+    let optnames =
+      if !all_dependencies
+      then match target_kind with
+        | MLI -> [basename ^ ".cmi"]
+        | ML  -> [basename ^ ".cmi"; basename ^ ".cmx"]
+      else [ basename ^ ".cmx" ]
+    in
+    (bytenames @ byt_deps, optnames @  opt_deps)
   with Not_found ->
     (byt_deps, opt_deps)
 
@@ -128,22 +160,21 @@ let print_filename s =
   end
 ;;
 
-let print_dependencies target_file deps =
-  print_filename target_file; print_string depends_on;
+let print_dependencies target_files deps =
   let rec print_items pos = function
     [] -> print_string "\n"
   | dep :: rem ->
-      if pos + 1 + String.length dep <= 77 then begin
-        print_string " "; print_filename dep;
+    if !one_line || (pos + 1 + String.length dep <= 77) then begin
+        if pos <> 0 then print_string " "; print_filename dep;
         print_items (pos + String.length dep + 1) rem
       end else begin
         print_string escaped_eol; print_filename dep;
         print_items (String.length dep + 4) rem
       end in
-  print_items (String.length target_file + 1) deps
+  print_items 0 (target_files @ [depends_on] @ deps)
 
 let print_raw_dependencies source_file deps =
-  print_filename source_file; print_string ":";
+  print_filename source_file; print_string depends_on;
   Depend.StringSet.iter
     (fun dep ->
       if (String.length dep > 0)
@@ -182,11 +213,10 @@ let remove_preprocessed inputfile =
 
 let is_ast_file ic ast_magic =
   try
-    let buffer = String.create (String.length ast_magic) in
-    really_input ic buffer 0 (String.length ast_magic);
+    let buffer = Misc.input_bytes ic (String.length ast_magic) in
     if buffer = ast_magic then true
     else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then
-      failwith "Ocaml and preprocessor have incompatible versions"
+      failwith "OCaml and preprocessor have incompatible versions"
     else false
   with End_of_file -> false
 
@@ -197,6 +227,7 @@ let parse_use_file ic =
   else begin
     seek_in ic 0;
     let lb = Lexing.from_channel ic in
+    Location.init lb !Location.input_name;
     Parse.use_file lb
   end
 
@@ -207,57 +238,88 @@ let parse_interface ic =
   else begin
     seek_in ic 0;
     let lb = Lexing.from_channel ic in
+    Location.init lb !Location.input_name;
     Parse.interface lb
   end
 
 (* Process one file *)
 
-let ml_file_dependencies source_file =
+let report_err source_file exn =
+  error_occurred := true;
+  match exn with
+    | Lexer.Error(err, range) ->
+        Format.fprintf Format.err_formatter "@[%a%a@]@."
+        Location.print_error range  Lexer.report_error err
+    | Syntaxerr.Error err ->
+        Format.fprintf Format.err_formatter "@[%a@]@."
+        Syntaxerr.report_error err
+    | Sys_error msg ->
+        Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
+    | Preprocessing_error ->
+        Format.fprintf Format.err_formatter "@[Preprocessing error on file %s@]@."
+            source_file
+    | x -> raise x
+
+let read_parse_and_extract parse_function extract_function source_file =
   Depend.free_structure_names := Depend.StringSet.empty;
-  let input_file = preprocess source_file in
-  let ic = open_in_bin input_file in
   try
-    let ast = parse_use_file ic in
-    Depend.add_use_file Depend.StringSet.empty ast;
+    let input_file = preprocess source_file in
+    let ic = open_in_bin input_file in
+    try
+      let ast = parse_function ic in
+      extract_function Depend.StringSet.empty ast;
+      !Depend.free_structure_names
+    with x ->
+      close_in ic; remove_preprocessed input_file; raise x
+  with x ->
+    report_err source_file x;
+    Depend.StringSet.empty
+
+let ml_file_dependencies source_file =
+  let extracted_deps = read_parse_and_extract
+    parse_use_file Depend.add_use_file source_file
+  in
+  if !sort_files then
+    files := (source_file, ML, !Depend.free_structure_names) :: !files
+  else
     if !raw_dependencies then begin
-      print_raw_dependencies source_file !Depend.free_structure_names
+      print_raw_dependencies source_file extracted_deps
     end else begin
       let basename = Filename.chop_extension source_file in
-      let init_deps =
+      let byte_targets =
+        if !native_only then [] else [ basename ^ ".cmo" ] in
+      let native_targets =
+        if !all_dependencies
+        then [ basename ^ ".cmx"; basename ^ ".o" ]
+        else [ basename ^ ".cmx" ] in
+      let init_deps = if !all_dependencies then [source_file] else [] in
+      let cmi_name = basename ^ ".cmi" in
+      let init_deps, extra_targets =
         if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms
-        then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name])
-        else ([], []) in
-      let (byt_deps, opt_deps) =
-        Depend.StringSet.fold find_dependency
-                              !Depend.free_structure_names init_deps in
-      print_dependencies (basename ^ ".cmo") byt_deps;
-      print_dependencies (basename ^ ".cmx") opt_deps
-    end;
-    close_in ic; remove_preprocessed input_file
-  with x ->
-    close_in ic; remove_preprocessed input_file; raise x
+        then (cmi_name :: init_deps, cmi_name :: init_deps), []
+        else (init_deps, init_deps), ( if !all_dependencies then [cmi_name] else [] ) in
+      let (byt_deps, native_deps) =
+        Depend.StringSet.fold (find_dependency ML)
+          extracted_deps init_deps in
+      if not !native_only then print_dependencies (byte_targets @ extra_targets) byt_deps;
+      print_dependencies (native_targets @ extra_targets) native_deps;
+    end
 
 let mli_file_dependencies source_file =
-  Depend.free_structure_names := Depend.StringSet.empty;
-  let input_file = preprocess source_file in
-  let ic = open_in_bin input_file in
-  try
-    let ast = parse_interface ic in
-    Depend.add_signature Depend.StringSet.empty ast;
+  let extracted_deps = read_parse_and_extract
+    parse_interface Depend.add_signature source_file in
+  if !sort_files then
+    files := (source_file, MLI, extracted_deps) :: !files
+  else
     if !raw_dependencies then begin
-      print_raw_dependencies source_file !Depend.free_structure_names
+      print_raw_dependencies source_file extracted_deps
     end else begin
       let basename = Filename.chop_extension source_file in
       let (byt_deps, opt_deps) =
-        Depend.StringSet.fold find_dependency
-                              !Depend.free_structure_names ([], []) in
-      print_dependencies (basename ^ ".cmi") byt_deps
-    end;
-    close_in ic; remove_preprocessed input_file
-  with x ->
-    close_in ic; remove_preprocessed input_file; raise x
-
-type file_kind = ML | MLI;;
+        Depend.StringSet.fold (find_dependency MLI)
+          extracted_deps ([], []) in
+      print_dependencies [basename ^ ".cmi"] byt_deps
+    end
 
 let file_dependencies_as kind source_file =
   Location.input_name := source_file;
@@ -267,22 +329,7 @@ let file_dependencies_as kind source_file =
       | ML -> ml_file_dependencies source_file
       | MLI -> mli_file_dependencies source_file
     end
-  with x ->
-    let report_err = function
-    | Lexer.Error(err, range) ->
-        fprintf Format.err_formatter "@[%a%a@]@."
-        Location.print_error range  Lexer.report_error err
-    | Syntaxerr.Error err ->
-        fprintf Format.err_formatter "@[%a@]@."
-        Syntaxerr.report_error err
-    | Sys_error msg ->
-        fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
-    | Preprocessing_error ->
-        fprintf Format.err_formatter "@[Preprocessing error on file %s@]@."
-            source_file
-    | x -> raise x in
-    error_occurred := true;
-    report_err x
+  with x -> report_err source_file x
 
 let file_dependencies source_file =
   if List.exists (Filename.check_suffix source_file) !ml_synonyms then
@@ -291,17 +338,90 @@ let file_dependencies source_file =
     file_dependencies_as MLI source_file
   else ()
 
+let sort_files_by_dependencies files =
+  let h = Hashtbl.create 31 in
+  let worklist = ref [] in
+
+(* Init Hashtbl with all defined modules *)
+  let files = List.map (fun (file, file_kind, deps) ->
+    let modname = Filename.chop_extension (Filename.basename file) in
+    modname.[0] <- Char.uppercase modname.[0];
+    let key = (modname, file_kind) in
+    let new_deps = ref [] in
+    Hashtbl.add h key (file, new_deps);
+    worklist := key :: !worklist;
+    (modname, file_kind, deps, new_deps)
+  ) files in
+
+(* Keep only dependencies to defined modules *)
+  List.iter (fun (modname, file_kind, deps, new_deps) ->
+    let add_dep modname kind =
+      new_deps := (modname, kind) :: !new_deps;
+    in
+    Depend.StringSet.iter (fun modname ->
+      match file_kind with
+          ML -> (* ML depends both on ML and MLI *)
+            if Hashtbl.mem h (modname, MLI) then add_dep modname MLI;
+            if Hashtbl.mem h (modname, ML) then add_dep modname ML
+        | MLI -> (* MLI depends on MLI if exists, or ML otherwise *)
+          if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
+          else if Hashtbl.mem h (modname, ML) then add_dep modname ML
+    ) deps;
+    if file_kind = ML then (* add dep from .ml to .mli *)
+      if Hashtbl.mem h (modname, MLI) then add_dep modname MLI
+  ) files;
+
+(* Print and remove all files with no remaining dependency. Iterate
+   until all files have been removed (worklist is empty) or
+   no file was removed during a turn (cycle). *)
+  let printed = ref true in
+  while !printed && !worklist <> [] do
+    let files = !worklist in
+    worklist := [];
+    printed := false;
+    List.iter (fun key ->
+      let (file, deps) = Hashtbl.find h key in
+      let set = !deps in
+      deps := [];
+      List.iter (fun key ->
+        if Hashtbl.mem h key then deps := key :: !deps
+      ) set;
+      if !deps = [] then begin
+        printed := true;
+        Printf.printf "%s " file;
+        Hashtbl.remove h key;
+      end else
+        worklist := key :: !worklist
+    ) files
+  done;
+
+  if !worklist <> [] then begin
+    Format.fprintf Format.err_formatter
+      "@[Warning: cycle in dependencies. End of list is not sorted.@]@.";
+    Hashtbl.iter (fun _ (file, deps) ->
+      Format.fprintf Format.err_formatter "\t@[%s: " file;
+      List.iter (fun (modname, kind) ->
+        Format.fprintf Format.err_formatter "%s.%s " modname
+          (if kind=ML then "ml" else "mli");
+      ) !deps;
+      Format.fprintf Format.err_formatter "@]@.";
+      Printf.printf "%s " file) h;
+  end;
+  Printf.printf "\n%!";
+  ()
+
+
 (* Entry point *)
 
 let usage = "Usage: ocamldep [options] <source files>\nOptions are:"
 
 let print_version () =
-  printf "ocamldep, version %s@." Sys.ocaml_version;
+  Format.printf "ocamldep, version %s@." Sys.ocaml_version;
   exit 0;
 ;;
 
 let print_version_num () =
-  printf "%s@." Sys.ocaml_version;
+  Format.printf "%s@." Sys.ocaml_version;
   exit 0;
 ;;
 
@@ -310,26 +430,33 @@ let _ =
   add_to_load_path Filename.current_dir_name;
   Arg.parse [
      "-I", Arg.String add_to_load_path,
-       "<dir>  Add <dir> to the list of include directories";
+        "<dir>  Add <dir> to the list of include directories";
      "-impl", Arg.String (file_dependencies_as ML),
-       "<f> Process <f> as a .ml file";
+           "<f> Process <f> as a .ml file";
      "-intf", Arg.String (file_dependencies_as MLI),
-       "<f> Process <f> as a .mli file";
+           "<f> Process <f> as a .mli file";
      "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms),
        "<e> Consider <e> as a synonym of the .ml extension";
      "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms),
        "<e> Consider <e> as a synonym of the .mli extension";
+     "-sort", Arg.Set sort_files,
+              " Sort files according to their dependencies";
      "-modules", Arg.Set raw_dependencies,
-       " Print module dependencies in raw form (not suitable for make)";
+              " Print module dependencies in raw form (not suitable for make)";
      "-native", Arg.Set native_only,
-       "  Generate dependencies for a pure native-code project (no .cmo files)";
+             "  Generate dependencies for a pure native-code project (no .cmo files)";
+     "-all", Arg.Set all_dependencies,
+             "  Generate dependencies on all files (not accommodating for make shortcomings)";
+     "-one-line", Arg.Set one_line,
+             "  Output one line per file, regardless of the length";
      "-pp", Arg.String(fun s -> preprocessor := Some s),
-       "<cmd> Pipe sources through preprocessor <cmd>";
+         "<cmd> Pipe sources through preprocessor <cmd>";
      "-slash", Arg.Set force_slash,
-       "   (Windows) Use forward slash / instead of backslash \\ in file paths";
+            "   (Windows) Use forward slash / instead of backslash \\ in file paths";
      "-version", Arg.Unit print_version,
-      " Print version and exit";
+              " Print version and exit";
      "-vnum", Arg.Unit print_version_num,
-      " Print version number and exit";
+           "    Print version number and exit";
     ] file_dependencies usage;
+  if !sort_files then sort_files_by_dependencies !files;
   exit (if !error_occurred then 2 else 0)

diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp
index 2e2edd02499220fdb9cfd3caf62b49d145e9e394..3b31201ccfe0b816bcceb7a8f15f7be42c5330ac 100644 (file)
--- a/tools/ocamlmklib.mlp
+++ b/tools/ocamlmklib.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -32,7 +32,7 @@ and c_opts = ref []      (* options to pass to mksharedlib and ocamlc -ccopt *)
 and ld_opts = ref []        (* options to pass only to the linker *)
 and ocamlc = ref (compiler_path "ocamlc")
 and ocamlopt = ref (compiler_path "ocamlopt")
-and output = ref "a"        (* Output name for Caml part of library *)
+and output = ref "a"        (* Output name for OCaml part of library *)
 and output_c = ref ""       (* Output name for C part of library *)
 and rpath = ref []          (* rpath options *)
 and verbose = ref false
@@ -152,15 +152,15 @@ Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll
 \n  -help          Print this help message and exit\
 \n  --help         Same as -help\
 \n  -h             Same as -help\
-\n  -I <dir>       Add <dir> to the path searched for Caml object files\
+\n  -I <dir>       Add <dir> to the path searched for OCaml object files\
 \n  -failsafe      fall back to static linking if DLL construction failed\
 \n  -ldopt <opt>   C option passed to the shared linker only\
-\n  -linkall       Build Caml archive with link-all behavior\
+\n  -linkall       Build OCaml archive with link-all behavior\
 \n  -l<lib>        Specify a dependent C library\
 \n  -L<dir>        Add <dir> to the path searched for C libraries\
 \n  -ocamlc <cmd>  Use <cmd> in place of \"ocamlc\"\
 \n  -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"\
-\n  -o <name>      Generated Caml library is named <name>.cma or <name>.cmxa\
+\n  -o <name>      Generated OCaml library is named <name>.cma or <name>.cmxa\
 \n  -oc <name>     Generated C library is named dll<name>.so or lib<name>.a\
 \n  -rpath <dir>   Same as -dllpath <dir>\
 \n  -R<dir>        Same as -rpath\

diff --git a/tools/ocamlmktop.ml b/tools/ocamlmktop.ml
index 3d353a8f59f69dae4830af12c19cdff968bf6eba..0b4a8b0926e74657e7a6e26b3345e978ade483aa 100644 (file)
--- a/tools/ocamlmktop.ml
+++ b/tools/ocamlmktop.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl
index 477f7387ce35f90809f2aac8ce247be1664fe688..0f44da8ca2310a83ca4b8d0e0c1b31934741b09d 100644 (file)
--- a/tools/ocamlmktop.tpl
+++ b/tools/ocamlmktop.tpl
@@ -1,7 +1,7 @@
 #!/bin/sh
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Damien Doligez, projet Para, INRIA Rocquencourt            #
 #                                                                       #

diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
new file mode 100644 (file)
index 0000000..ce251e5
--- /dev/null
+++ b/tools/ocamloptp.ml
@@ -0,0 +1,156 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2012 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: ocamlcp.ml 11890 2011-12-20 10:35:43Z frisch $ *)
+
+open Printf
+
+let compargs = ref ([] : string list)
+let profargs = ref ([] : string list)
+let toremove = ref ([] : string list)
+
+let option opt () = compargs := opt :: !compargs
+let option_with_arg opt arg =
+  compargs := (Filename.quote arg) :: opt :: !compargs
+;;
+let option_with_int opt arg =
+  compargs := (string_of_int arg) :: opt :: !compargs
+;;
+
+let make_archive = ref false;;
+let with_impl = ref false;;
+let with_intf = ref false;;
+let with_mli = ref false;;
+let with_ml = ref false;;
+
+let process_file filename =
+  if Filename.check_suffix filename ".ml" then with_ml := true;
+  if Filename.check_suffix filename ".mli" then with_mli := true;
+  compargs := (Filename.quote filename) :: !compargs
+;;
+
+let usage = "Usage: ocamloptp <options> <files>\noptions are:"
+
+let incompatible o =
+  fprintf stderr "ocamloptp: profiling is incompatible with the %s option\n" o;
+  exit 2
+
+module Options = Main_args.Make_optcomp_options (struct
+  let _a () = make_archive := true; option "-a" ()
+  let _absname = option "-absname"
+  let _annot = option "-annot"
+  let _c = option "-c"
+  let _cc s = option_with_arg "-cc" s
+  let _cclib s = option_with_arg "-cclib" s
+  let _ccopt s = option_with_arg "-ccopt" s
+  let _compact = option "-compact"
+  let _config = option "-config"
+  let _for_pack s = option_with_arg "-for-pack" s
+  let _g = option "-g"
+  let _i = option "-i"
+  let _I s = option_with_arg "-I" s
+  let _impl s = with_impl := true; option_with_arg "-impl" s
+  let _inline n = option_with_int "-inline" n
+  let _intf s = with_intf := true; option_with_arg "-intf" s
+  let _intf_suffix s = option_with_arg "-intf-suffix" s
+  let _labels = option "-labels"
+  let _linkall = option "-linkall"
+  let _no_app_funct = option "-no-app-funct"
+  let _noassert = option "-noassert"
+  let _noautolink = option "-noautolink"
+  let _nodynlink = option "-nodynlink"
+  let _nolabels = option "-nolabels"
+  let _nostdlib = option "-nostdlib"
+  let _o s = option_with_arg "-o" s
+  let _output_obj = option "-output-obj"
+  let _p = option "-p"
+  let _pack = option "-pack"
+  let _pp s = incompatible "-pp"
+  let _principal = option "-principal"
+  let _rectypes = option "-rectypes"
+  let _runtime_variant s = option_with_arg "-runtime-variant" s
+  let _S = option "-S"
+  let _strict_sequence = option "-strict-sequence"
+  let _shared = option "-shared"
+  let _thread = option "-thread"
+  let _unsafe = option "-unsafe"
+  let _v = option "-v"
+  let _version = option "-version"
+  let _vnum = option "-vnum"
+  let _verbose = option "-verbose"
+  let _w = option_with_arg "-w"
+  let _warn_error = option_with_arg "-warn-error"
+  let _warn_help = option "-warn-help"
+  let _where = option "-where"
+
+  let _nopervasives = option "-nopervasives"
+  let _dparsetree = option "-dparsetree"
+  let _drawlambda = option "-drawlambda"
+  let _dlambda = option "-dlambda"
+  let _dclambda = option "-dclambda"
+  let _dcmm = option "-dcmm"
+  let _dsel = option "-dsel"
+  let _dcombine = option "-dcombine"
+  let _dlive = option "-dlive"
+  let _dspill = option "-dspill"
+  let _dsplit = option "-dsplit"
+  let _dinterf = option "-dinterf"
+  let _dprefer = option "-dprefer"
+  let _dalloc = option "-dalloc"
+  let _dreload = option "-dreload"
+  let _dscheduling = option "-dscheduling"
+  let _dlinear = option "-dlinear"
+  let _dstartup = option "-dstartup"
+
+  let anonymous = process_file
+end);;
+
+let add_profarg s =
+  profargs := (Filename.quote s) :: "-m" :: !profargs
+;;
+
+let optlist =
+    ("-P", Arg.String add_profarg,
+           "[afilmt]  Profile constructs specified by argument (default fm):\n\
+        \032     a  Everything\n\
+        \032     f  Function calls and method calls\n\
+        \032     i  if ... then ... else\n\
+        \032     l  while and for loops\n\
+        \032     m  match ... with\n\
+        \032     t  try ... with")
+    :: Options.list
+in
+Arg.parse optlist process_file usage;
+if !with_impl && !with_intf then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-impl\" and \"-intf\"\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end else if !with_impl && !with_mli then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-impl\" and .mli files\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end else if !with_intf && !with_ml then begin
+  fprintf stderr "ocamloptp cannot deal with both \"-intf\" and .ml files\n";
+  fprintf stderr "please compile interfaces and implementations separately\n";
+  exit 2;
+end;
+if !with_impl then profargs := "-impl" :: !profargs;
+if !with_intf then profargs := "-intf" :: !profargs;
+let status =
+  Sys.command
+    (Printf.sprintf "ocamlopt -pp \"ocamlprof -instrument %s\" %s %s"
+        (String.concat " " (List.rev !profargs))
+        (if !make_archive then "" else "profiling.cmx")
+        (String.concat " " (List.rev !compargs)))
+in
+exit status
+;;

diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index e561f60e627563070fb91fcc3ab0b10577bd466b..b8a6b3fa407eba3a460fcbb524731a071b7b7987 100644 (file)
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
 (*          Ported to Caml Special Light by John Malecki               *)
@@ -287,7 +287,7 @@ and rw_exp iflag sexp =
 
   | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp
   | Pexp_open (_, e) -> rewrite_exp iflag e
-  | Pexp_pack (smod, _) -> rewrite_mod iflag smod
+  | Pexp_pack (smod) -> rewrite_mod iflag smod
 
 and rewrite_ifbody iflag ghost sifbody =
   if !instr_if && not ghost then
@@ -328,8 +328,6 @@ and rewrite_class_field iflag =
   | Pcf_meth (_, _, _, sexp, loc) ->
       if !instr_fun && not loc.loc_ghost then insert_profile rw_exp sexp
       else rewrite_exp iflag sexp
-  | Pcf_let(_, spat_sexp_list, _) ->
-      rewrite_patexp_list iflag spat_sexp_list
   | Pcf_init sexp ->
       rewrite_exp iflag sexp
   | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _  -> ()
@@ -362,7 +360,7 @@ and rewrite_mod iflag smod =
   | Pmod_functor(param, smty, sbody) -> rewrite_mod iflag sbody
   | Pmod_apply(smod1, smod2) -> rewrite_mod iflag smod1; rewrite_mod iflag smod2
   | Pmod_constraint(smod, smty) -> rewrite_mod iflag smod
-  | Pmod_unpack(sexp, _) -> rewrite_exp iflag sexp
+  | Pmod_unpack(sexp) -> rewrite_exp iflag sexp
 
 and rewrite_str_item iflag item =
   match item.pstr_desc with

diff --git a/tools/ocamlsize b/tools/ocamlsize
index 659543d5930c7c17caec67425fd252316468cf6b..7b419cebace38f2f702342a3c9fa931702bcd3b4 100755 (executable)
--- a/tools/ocamlsize
+++ b/tools/ocamlsize
@@ -1,5 +1,17 @@
 #!/usr/bin/perl
 
+#######################################################################
+#                                                                     #
+#                                OCaml                                #
+#                                                                     #
+#            Xavier Leroy, projet Cristal, INRIA Rocquencourt         #
+#                                                                     #
+#  Copyright 2002 Institut National de Recherche en Informatique et   #
+#  en Automatique.  All rights reserved.  This file is distributed    #
+#  under the terms of the Q Public License version 1.0.               #
+#                                                                     #
+#######################################################################
+
 foreach $f (@ARGV) {
     open(FILE, $f) || die("Cannot open $f");
     seek(FILE, -16, 2);

diff --git a/tools/primreq.ml b/tools/primreq.ml
index dcace11ba706386e699a20f07281186b3e7bc5fc..c1764f5df634c69f86dc65c97499078704404789 100644 (file)
--- a/tools/primreq.ml
+++ b/tools/primreq.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/tools/profiling.ml b/tools/profiling.ml
index 9c6d9dd02b3f1d3f643c842a45e6abcc24ea6e86..06c9761094e64fbbe723381d5262aaf09be06998 100644 (file)
--- a/tools/profiling.ml
+++ b/tools/profiling.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
 (*   Ported to Caml Special Light by John Malecki and Xavier Leroy     *)

diff --git a/tools/profiling.mli b/tools/profiling.mli
index ca8486f4361ae6b6818e1959428566f86d5ee6ab..61be2be760ac141582bfff0e54e9e726b06f68da 100644 (file)
--- a/tools/profiling.mli
+++ b/tools/profiling.mli
@@ -1,9 +1,9 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*      Damien Doligez and Francois Rouaix, INRIA Rocquencourt         *)
-(*   Ported to Objective Caml by John Malecki and Xavier Leroy         *)
+(*   Ported to OCaml by John Malecki and Xavier Leroy                  *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)

diff --git a/tools/scrapelabels.ml b/tools/scrapelabels.ml
index dc43e97b702ed0512836ef70b42ca027b85d3252..3d8ab032c733643b49c7f0cb3fb6219cfefbceb3 100644 (file)
--- a/tools/scrapelabels.ml
+++ b/tools/scrapelabels.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*              Jacques Garrigue, Kyoto University RIMS                *)
 (*                                                                     *)

diff --git a/tools/setignore b/tools/setignore
new file mode 100755 (executable)
index 0000000..708ed26
--- /dev/null
+++ b/tools/setignore
@@ -0,0 +1,39 @@
+#!/bin/sh
+
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#          Damien Doligez, projet Gallium, INRIA Rocquencourt           #
+#                                                                       #
+#   Copyright 2011 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+(
+  cat <<EOF
+*.o
+*.a
+*.so
+*.obj
+
+*.cm[ioxa]
+*.cmx[as]
+*.annot
+
+*.result
+*.byte
+*.native
+program
+
+.depend
+.depend.nt
+.DS_Store
+
+EOF
+
+  if [ -f .ignore ]; then cat .ignore; fi
+
+) | svn propset svn:ignore -F - .

diff --git a/toplevel/expunge.ml b/toplevel/expunge.ml
index 5debb412439e18a80bdd21b723c546c499f0e947..9cdcbf89e1f7709a097eac7f127abcde2443995f 100644 (file)
--- a/toplevel/expunge.ml
+++ b/toplevel/expunge.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,23 +24,29 @@ module StringSet =
     let compare = compare
   end)
 
+let is_exn =
+  let h = Hashtbl.create 64 in
+  Array.iter (fun n -> Hashtbl.add h n ()) Runtimedef.builtin_exceptions;
+  Hashtbl.mem h
+
 let to_keep = ref StringSet.empty
 
+let negate = Sys.argv.(3) = "-v"
+
+let keep = 
+  if negate then fun name -> is_exn name || not (StringSet.mem name !to_keep)
+  else fun name -> is_exn name || (StringSet.mem name !to_keep)
+
 let expunge_map tbl =
-  Symtable.filter_global_map
-    (fun id -> StringSet.mem (Ident.name id) !to_keep)
-    tbl
+  Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl
 
 let expunge_crcs tbl =
-  List.filter (fun (unit, crc) -> StringSet.mem unit !to_keep) tbl
+  List.filter (fun (unit, crc) -> keep unit) tbl
 
 let main () =
   let input_name = Sys.argv.(1) in
   let output_name = Sys.argv.(2) in
-  Array.iter
-    (fun exn -> to_keep := StringSet.add exn !to_keep)
-    Runtimedef.builtin_exceptions;
-  for i = 3 to Array.length Sys.argv - 1 do
+  for i = (if negate then 4 else 3) to Array.length Sys.argv - 1 do
     to_keep := StringSet.add (String.capitalize Sys.argv.(i)) !to_keep
   done;
   let ic = open_in_bin input_name in

diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 327700400668505e707239dcfb7c1c95f512f2f1..2bf72f19c1941a9163160c682cc67a6fa87c396e 100644 (file)
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -180,7 +180,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
           find_printer env ty obj
         with Not_found ->
           match (Ctype.repr ty).desc with
-          | Tvar ->
+          | Tvar _ | Tunivar _ ->
               Oval_stuff "<poly>"
           | Tarrow(_, ty1, ty2, _) ->
               Oval_stuff "<fun>"
@@ -247,16 +247,25 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
                       if O.is_block obj
                       then Cstr_block(O.tag obj)
                       else Cstr_constant(O.obj obj) in
-                    let (constr_name, constr_args) =
+                    let (constr_name, constr_args,ret_type) =
                       Datarepr.find_constr_by_tag tag constr_list in
+                   let type_params = 
+                     match ret_type with
+                       Some t -> 
+                         begin match (Ctype.repr t).desc with 
+                           Tconstr (_,params,_) ->
+                             params
+                         | _ -> assert false end
+                     | None -> decl.type_params
+                   in
                     let ty_args =
                       List.map
                         (function ty ->
-                           try Ctype.apply env decl.type_params ty ty_list with
+                           try Ctype.apply env type_params ty ty_list with
                              Ctype.Cannot_apply -> abstract_type)
                         constr_args in
                     tree_of_constr_with_args (tree_of_constr env path)
-                                           constr_name 0 depth obj ty_args
+                                           constr_name 0 depth obj ty_args                 
                 | {type_kind = Type_record(lbl_list, rep)} ->
                     begin match check_depth depth obj ty with
                       Some x -> x
@@ -318,8 +327,6 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
               fatal_error "Printval.outval_of_value"
           | Tpoly (ty, _) ->
               tree_of_val (depth - 1) obj ty
-          | Tunivar ->
-              Oval_stuff "<poly>"
           | Tpackage _ ->
               Oval_stuff "<module>"
         end
@@ -347,7 +354,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
         let cstr = Env.lookup_constructor lid env in
         let path =
           match cstr.cstr_tag with
-            Cstr_exception p -> p | _ -> raise Not_found in
+            Cstr_exception (p, _) -> p | _ -> raise Not_found in
         (* Make sure this is the right exception and not an homonym,
            by evaluating the exception found and comparing with the
            identifier contained in the exception bucket *)

diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
index 898588b2ddbbcf3b90b1c663293b576d37171e5f..6522cccdb0a5a51aeebbce3c1c09332f4cc36744 100644 (file)
--- a/toplevel/genprintval.mli
+++ b/toplevel/genprintval.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
 (*                                                                     *)

diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml
index b586bae1c8c771f7109fcb0e754184da59d7bf2d..8655ef96b0f9e56e80ddf1bb8026167cac47cf8c 100644 (file)
--- a/toplevel/opttopdirs.ml
+++ b/toplevel/opttopdirs.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -112,7 +112,7 @@ let match_printer_type ppf desc typename =
   let ty_arg = Ctype.newvar() in
   Ctype.unify !toplevel_env
     (Ctype.newconstr printer_type [ty_arg])
-    (Ctype.instance desc.val_type);
+    (Ctype.instance_def desc.val_type);
   Ctype.end_def();
   Ctype.generalize ty_arg;
   ty_arg

diff --git a/toplevel/opttopdirs.mli b/toplevel/opttopdirs.mli
index 800c6cf7bdadf19ddde78235d07c4b4643e93aed..9a8573e57df816e8093e5b673ec4a267794ccac4 100644 (file)
--- a/toplevel/opttopdirs.mli
+++ b/toplevel/opttopdirs.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml
index ee6b5a0eab2b90372cf1624d4721b2cfeea26f6b..8d83908d009b6521986d33bd631d207b69880ec4 100644 (file)
--- a/toplevel/opttoploop.ml
+++ b/toplevel/opttoploop.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -225,7 +225,6 @@ let execute_phrase print_outcome ppf phr =
       incr phrase_seqid;
       phrase_name := Printf.sprintf "TOP%i" !phrase_seqid;
       Compilenv.reset ?packname:None !phrase_name;
-      let _ = Unused_var.warn ppf sstr in
       Typecore.reset_delayed_checks ();
       let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
       in
@@ -301,8 +300,15 @@ let use_print_results = ref true
 
 let use_file ppf name =
   try
-    let filename = find_in_path !Config.load_path name in
-    let ic = open_in_bin filename in
+    let (filename, ic, must_close) =
+      if name = "" then
+        ("(stdin)", stdin, false)
+      else begin
+        let filename = find_in_path !Config.load_path name in
+        let ic = open_in_bin filename in
+        (filename, ic, true)
+      end
+    in
     let lb = Lexing.from_channel ic in
     Location.init lb filename;
     (* Skip initial #! line if any *)
@@ -320,7 +326,7 @@ let use_file ppf name =
         | Exit -> false
         | Sys.Break -> fprintf ppf "Interrupted.@."; false
         | x -> Opterrors.report_error ppf x; false) in
-    close_in ic;
+    if must_close then close_in ic;
     success
   with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
 
@@ -357,6 +363,7 @@ let refill_lexbuf buffer len =
     let prompt =
       if !Clflags.noprompt then ""
       else if !first_line then "# "
+      else if !Clflags.nopromptcont then ""
       else if Lexer.in_comment () then "* "
       else "  "
     in
@@ -409,10 +416,11 @@ let initialize_toplevel_env () =
 exception PPerror
 
 let loop ppf =
-  fprintf ppf "        Objective Caml version %s - native toplevel@.@." Config.version;
+  fprintf ppf "        OCaml version %s - native toplevel@.@." Config.version;
   initialize_toplevel_env ();
   let lb = Lexing.from_function refill_lexbuf in
-  Location.input_name := "";
+  Location.init lb "//toplevel//";
+  Location.input_name := "//toplevel//";
   Location.input_lexbuf := Some lb;
   Sys.catch_break true;
   load_ocamlinit ppf;

diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli
index 78e45f0bab667f0a80d97c3f0e79e2470dc0ef42..cdd32de121350b7f85c2f57c34da283eba2f0345 100644 (file)
--- a/toplevel/opttoploop.mli
+++ b/toplevel/opttoploop.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml
index bd27abb760b6fe796b5c27c9508e03fd3fed9c6a..ac32a5c1081c2760c6083a457a4942e291f63278 100644 (file)
--- a/toplevel/opttopmain.ml
+++ b/toplevel/opttopmain.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -49,7 +49,7 @@ let file_argument name =
     end
 
 let print_version () =
-  Printf.printf "The Objective Caml toplevel, version %s\n" Sys.ocaml_version;
+  Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version;
   exit 0;
 ;;
 
@@ -62,6 +62,7 @@ module Options = Main_args.Make_opttop_options (struct
   let set r () = r := true
   let clear r () = r := false
 
+  let _absname = set Location.absname
   let _compact = clear optimize_for_speed
   let _I dir =
     let dir = Misc.expand_directory Config.standard_library dir in
@@ -73,11 +74,13 @@ module Options = Main_args.Make_opttop_options (struct
   let _noassert = set noassert
   let _nolabels = set classic
   let _noprompt = set noprompt
+  let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
   let _principal = set principal
   let _rectypes = set recursive_types
   let _strict_sequence = set strict_sequence
   let _S = set keep_asm_file
+  let _stdin () = file_argument ""
   let _unsafe = set fast
   let _version () = print_version ()
   let _vnum () = print_version_num ()

diff --git a/toplevel/opttopmain.mli b/toplevel/opttopmain.mli
index 197f88bbc6721dee71ece2438258c1d50fd0a2d8..61747d892fbb8a081ab0a7ccaf52363025d61d5f 100644 (file)
--- a/toplevel/opttopmain.mli
+++ b/toplevel/opttopmain.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/opttopstart.ml b/toplevel/opttopstart.ml
index 3e3fe58baf4428d47dfbe6c7eb87fc0c895a92e8..db279940ecee6d78590acd87aeb5e2e58099c8d9 100644 (file)
--- a/toplevel/opttopstart.ml
+++ b/toplevel/opttopstart.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 6516a387703c433316ec5dcc73dbad00e39b409f..bca4709829963cd839c381e701085d5d254c3daf 100644 (file)
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -85,19 +85,43 @@ let load_compunit ic filename ppf compunit =
     raise Load_failed
   end
 
-let load_file ppf name =
+let rec load_file recursive ppf name =
+  let filename = try Some (find_in_path !Config.load_path name) with Not_found -> None in
+  match filename with
+  | None -> fprintf ppf "Cannot find file %s.@." name; false
+  | Some filename ->
+      let ic = open_in_bin filename in
+      try
+        let success = really_load_file recursive ppf name filename ic in
+        close_in ic;
+        success
+      with exn ->
+        close_in ic;
+        raise exn
+
+and really_load_file recursive ppf name filename ic =
+  let ic = open_in_bin filename in
+  let buffer = Misc.input_bytes ic (String.length Config.cmo_magic_number) in
   try
-    let filename = find_in_path !Config.load_path name in
-    let ic = open_in_bin filename in
-    let buffer = String.create (String.length Config.cmo_magic_number) in
-    really_input ic buffer 0 (String.length Config.cmo_magic_number);
-    let success = try
-      if buffer = Config.cmo_magic_number then begin
-        let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
-        seek_in ic compunit_pos;
-        load_compunit ic filename ppf (input_value ic : compilation_unit);
-        true
-      end else
+    if buffer = Config.cmo_magic_number then begin
+      let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
+      seek_in ic compunit_pos;
+      let cu : compilation_unit = input_value ic in
+      if recursive then
+        List.iter
+          (function
+            | (Reloc_getglobal id, _) when not (Symtable.is_global_defined id) ->
+                let file = Ident.name id ^ ".cmo" in
+                begin match try Some (Misc.find_in_path_uncap !Config.load_path file) with Not_found -> None with
+                | None -> ()
+                | Some file -> if not (load_file recursive ppf file) then raise Load_failed
+                end
+            | _ -> ()
+          )
+          cu.cu_reloc;
+      load_compunit ic filename ppf cu;
+      true
+    end else
       if buffer = Config.cma_magic_number then begin
         let toc_pos = input_binary_int ic in  (* Go to table of contents *)
         seek_in ic toc_pos;
@@ -118,15 +142,18 @@ let load_file ppf name =
         fprintf ppf "File %s is not a bytecode object file.@." name;
         false
       end
-    with Load_failed -> false in
-    close_in ic;
-    success
-  with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
+  with Load_failed -> false
 
-let dir_load ppf name = ignore (load_file ppf name)
+let dir_load ppf name = ignore (load_file false ppf name)
 
 let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out))
 
+let dir_load_rec ppf name = ignore (load_file true ppf name)
+
+let _ = Hashtbl.add directive_table "load_rec" (Directive_string (dir_load_rec std_out))
+
+let load_file = load_file false
+
 (* Load commands from a file *)
 
 let dir_use ppf name = ignore(Toploop.use_file ppf name)
@@ -150,7 +177,7 @@ let match_printer_type ppf desc typename =
   let ty_arg = Ctype.newvar() in
   Ctype.unify !toplevel_env
     (Ctype.newconstr printer_type [ty_arg])
-    (Ctype.instance desc.val_type);
+    (Ctype.instance_def desc.val_type);
   Ctype.end_def();
   Ctype.generalize ty_arg;
   ty_arg

diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli
index 36af2211baa3b7d5d9cfadd34abf23e9d1fc2220..11aa9b851bb7778b398d0e7fd25bda829fc67d60 100644 (file)
--- a/toplevel/topdirs.mli
+++ b/toplevel/topdirs.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/toplevellib.mllib b/toplevel/toplevellib.mllib
index a5e8b03f24e41396aace89674e63d8fa2cacb021..eb459a906d97bb7104dfe4d5be06b04469537b0a 100644 (file)
--- a/toplevel/toplevellib.mllib
+++ b/toplevel/toplevellib.mllib
@@ -1,7 +1,7 @@
 Myocamlbuild_config
 Misc Tbl Config Clflags Terminfo Ccomp Warnings Consistbl
 
-Linenum Location Longident Syntaxerr Parser
+Location Longident Syntaxerr Parser
 Lexer Parse Printast
 
 Unused_var Ident Path Primitive Types

diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index 250a27b52c306d755374f81585cd0510499380f9..6a83bcc9cf86d568b3400667b1dd6350845a04fd 100644 (file)
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -217,7 +217,6 @@ let execute_phrase print_outcome ppf phr =
   match phr with
   | Ptop_def sstr ->
       let oldenv = !toplevel_env in
-      let _ = Unused_var.warn ppf sstr in
       Typecore.reset_delayed_checks ();
       let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
       in
@@ -284,14 +283,21 @@ let protect r newval body =
     r := oldval;
     raise x
 
-(* Read and execute commands from a file *)
+(* Read and execute commands from a file, or from stdin if [name] is "". *)
 
 let use_print_results = ref true
 
 let use_file ppf name =
   try
-    let filename = find_in_path !Config.load_path name in
-    let ic = open_in_bin filename in
+    let (filename, ic, must_close) =
+      if name = "" then
+        ("(stdin)", stdin, false)
+      else begin
+        let filename = find_in_path !Config.load_path name in
+        let ic = open_in_bin filename in
+        (filename, ic, true)
+      end
+    in
     let lb = Lexing.from_channel ic in
     Location.init lb filename;
     (* Skip initial #! line if any *)
@@ -309,7 +315,7 @@ let use_file ppf name =
         | Exit -> false
         | Sys.Break -> fprintf ppf "Interrupted.@."; false
         | x -> Errors.report_error ppf x; false) in
-    close_in ic;
+    if must_close then close_in ic;
     success
   with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
 
@@ -346,6 +352,7 @@ let refill_lexbuf buffer len =
     let prompt =
       if !Clflags.noprompt then ""
       else if !first_line then "# "
+      else if !Clflags.nopromptcont then ""
       else if Lexer.in_comment () then "* "
       else "  "
     in
@@ -400,10 +407,11 @@ let initialize_toplevel_env () =
 exception PPerror
 
 let loop ppf =
-  fprintf ppf "        Objective Caml version %s@.@." Config.version;
+  fprintf ppf "        OCaml version %s@.@." Config.version;
   initialize_toplevel_env ();
   let lb = Lexing.from_function refill_lexbuf in
-  Location.input_name := "";
+  Location.init lb "//toplevel//";
+  Location.input_name := "//toplevel//";
   Location.input_lexbuf := Some lb;
   Sys.catch_break true;
   load_ocamlinit ppf;
@@ -415,6 +423,7 @@ let loop ppf =
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
       if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+      Env.reset_missing_cmis ();
       ignore(execute_phrase true ppf phr)
     with
     | End_of_file -> exit 0
@@ -423,7 +432,7 @@ let loop ppf =
     | x -> Errors.report_error ppf x; Btype.backtrack snap
   done
 
-(* Execute a script *)
+(* Execute a script.  If [name] is "", read the script from stdin. *)
 
 let run_script ppf name args =
   let len = Array.length args in

diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index 35eb5dbf5bfcca6623cf108b069cec97e2b6e038..e9afb5a0dfefc95d2201503a8984e2de5c3cfa6a 100644 (file)
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index 4bf9922a119716548f846f653ded8945a02a27c7..27b2ca2876eeb5d3110281c964131f2f0ee8861f 100644 (file)
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -14,7 +14,8 @@
 
 open Clflags
 
-let usage = "Usage: ocaml <options> <object-files> [script-file]\noptions are:"
+let usage = "Usage: ocaml <options> <object-files> [script-file [arguments]]\n\
+             options are:"
 
 let preload_objects = ref []
 
@@ -31,6 +32,7 @@ let prepare ppf =
       Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
       false
 
+(* If [name] is "", then the "file" is stdin treated as a script file. *)
 let file_argument name =
   let ppf = Format.err_formatter in
   if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
@@ -46,7 +48,7 @@ let file_argument name =
     end
 
 let print_version () =
-  Printf.printf "The Objective Caml toplevel, version %s\n" Sys.ocaml_version;
+  Printf.printf "The OCaml toplevel, version %s\n" Sys.ocaml_version;
   exit 0;
 ;;
 
@@ -59,6 +61,7 @@ module Options = Main_args.Make_bytetop_options (struct
   let set r () = r := true
   let clear r () = r := false
 
+  let _absname = set Location.absname
   let _I dir =
     let dir = Misc.expand_directory Config.standard_library dir in
     include_dirs := dir :: !include_dirs
@@ -68,9 +71,11 @@ module Options = Main_args.Make_bytetop_options (struct
   let _noassert = set noassert
   let _nolabels = set classic
   let _noprompt = set noprompt
+  let _nopromptcont = set nopromptcont
   let _nostdlib = set no_std_include
   let _principal = set principal
   let _rectypes = set recursive_types
+  let _stdin () = file_argument ""
   let _strict_sequence = set strict_sequence
   let _unsafe = set fast
   let _version () = print_version ()

diff --git a/toplevel/topmain.mli b/toplevel/topmain.mli
index 197f88bbc6721dee71ece2438258c1d50fd0a2d8..61747d892fbb8a081ab0a7ccaf52363025d61d5f 100644 (file)
--- a/toplevel/topmain.mli
+++ b/toplevel/topmain.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/topstart.ml b/toplevel/topstart.ml
index 570e2f203a620f120f6f9c1139b14b6839904c61..823b4c813a9f3e4dc0b1f74bd232e43af096d977 100644 (file)
--- a/toplevel/topstart.ml
+++ b/toplevel/topstart.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/trace.ml b/toplevel/trace.ml
index fad92d98a3599f009558e1c3ce2fe2e7fb6c452f..104f39fe4bb109e82008c08811a3bba73eacdb89 100644 (file)
--- a/toplevel/trace.ml
+++ b/toplevel/trace.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/toplevel/trace.mli b/toplevel/trace.mli
index d708361c7cbb8d18f97d3878c97356dcd00031a2..0675dd1bf6c61c1a5d972294b3678a7361117c05 100644 (file)
--- a/toplevel/trace.mli
+++ b/toplevel/trace.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/annot.mli b/typing/annot.mli
index 92b2f6ec694a275f5b0cbaf768b998d01407e905..934438194eda108cddf6d01842321d5e38aa968d 100644 (file)
--- a/typing/annot.mli
+++ b/typing/annot.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Gallium, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/btype.ml b/typing/btype.ml
index e57e760f2e21ec2018bd091f54e3cbf12c72d76b..c9bdbf04d454c0811081be53ae46c4a7c47fa94e 100644 (file)
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -16,6 +16,17 @@
 
 open Types
 
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet = Set.Make(TypeOps)
+module TypeMap = Map.Make (TypeOps)
+module TypeHash = Hashtbl.Make(TypeOps)
+
+(**** Forward declarations ****)
+
+let print_raw =
+  ref (fun _ -> assert false : Format.formatter -> type_expr -> unit)
+
 (**** Type level management ****)
 
 let generic_level = 100000000
@@ -30,9 +41,9 @@ let pivot_level = 2 * lowest_level - 1
 let new_id = ref (-1)
 
 let newty2 level desc  =
-  incr new_id; { desc = desc; level = level; id = !new_id }
+  incr new_id; { desc; level; id = !new_id }
 let newgenty desc      = newty2 generic_level desc
-let newgenvar ()       = newgenty Tvar
+let newgenvar ?name () = newgenty (Tvar name)
 (*
 let newmarkedvar level =
   incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
@@ -41,6 +52,11 @@ let newmarkedgenvar () =
   { desc = Tvar; level = pivot_level - generic_level; id = !new_id }
 *)
 
+(**** Check some types ****)
+
+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+
 (**** Representative of a type ****)
 
 let rec field_kind_repr =
@@ -134,7 +150,7 @@ let proxy ty =
       let rec proxy_obj ty =
         match ty.desc with
           Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
-        | Tvar | Tunivar | Tconstr _ -> ty
+        | Tvar _ | Tunivar _ | Tconstr _ -> ty
         | Tnil -> ty0
         | _ -> assert false
       in proxy_obj ty
@@ -175,13 +191,13 @@ let rec iter_row f row =
     row.row_fields;
   match (repr row.row_more).desc with
     Tvariant row -> iter_row f row
-  | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
+  | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil ->
       Misc.may (fun (_,l) -> List.iter f l) row.row_name
   | _ -> assert false
 
 let iter_type_expr f ty =
   match ty.desc with
-    Tvar                -> ()
+    Tvar _              -> ()
   | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
   | Ttuple l            -> List.iter f l
   | Tconstr (_, l, _)   -> List.iter f l
@@ -193,7 +209,7 @@ let iter_type_expr f ty =
   | Tnil                -> ()
   | Tlink ty            -> f ty
   | Tsubst ty           -> f ty
-  | Tunivar             -> ()
+  | Tunivar _           -> ()
   | Tpoly (ty, tyl)     -> f ty; List.iter f tyl
   | Tpackage (_, _, l)  -> List.iter f l
 
@@ -234,13 +250,13 @@ let copy_commu c =
    encoding during substitution *)
 let rec norm_univar ty =
   match ty.desc with
-    Tunivar | Tsubst _ -> ty
+    Tunivar _ | Tsubst _ -> ty
   | Tlink ty           -> norm_univar ty
   | Ttuple (ty :: _)   -> norm_univar ty
   | _                  -> assert false
 
 let rec copy_type_desc f = function
-    Tvar                -> Tvar
+    Tvar _              -> Tvar None (* forget the name *)
   | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
   | Ttuple l            -> Ttuple (List.map f l)
   | Tconstr (p, l, _)   -> Tconstr (p, List.map f l, ref Mnil)
@@ -253,7 +269,7 @@ let rec copy_type_desc f = function
   | Tnil                -> Tnil
   | Tlink ty            -> copy_type_desc f ty.desc
   | Tsubst ty           -> assert false
-  | Tunivar             -> Tunivar
+  | Tunivar _ as ty     -> ty (* keep the name *)
   | Tpoly (ty, tyl)     ->
       let tyl = List.map (fun x -> norm_univar (f x)) tyl in
       Tpoly (f ty, tyl)
@@ -314,7 +330,11 @@ let unmark_type_decl decl =
   begin match decl.type_kind with
     Type_abstract -> ()
   | Type_variant cstrs ->
-      List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
+      List.iter 
+       (fun (c, tl, ret_type_opt) -> 
+         List.iter unmark_type tl;
+         Misc.may unmark_type ret_type_opt)
+       cstrs
   | Type_record(lbls, rep) ->
       List.iter (fun (c, mut, t) -> unmark_type t) lbls
   end;
@@ -436,15 +456,17 @@ type change =
   | Ckind of field_kind option ref * field_kind option
   | Ccommu of commutable ref * commutable
   | Cuniv of type_expr option ref * type_expr option
+  | Ctypeset of TypeSet.t ref * TypeSet.t
 
 let undo_change = function
-    Ctype  (ty, desc)  -> ty.desc <- desc
+    Ctype  (ty, desc) -> ty.desc <- desc
   | Clevel (ty, level) -> ty.level <- level
   | Cname  (r, v) -> r := v
   | Crow   (r, v) -> r := v
   | Ckind  (r, v) -> r := v
   | Ccommu (r, v) -> r := v
   | Cuniv  (r, v) -> r := v
+  | Ctypeset (r, v) -> r := v
 
 type changes =
     Change of change * changes ref
@@ -465,7 +487,22 @@ let log_change ch =
 
 let log_type ty =
   if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
-let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
+let link_type ty ty' =
+  log_type ty;
+  let desc = ty.desc in
+  ty.desc <- Tlink ty';
+  (* Name is a user-supplied name for this unification variable (obtained
+   * through a type annotation for instance). *)
+  match desc, ty'.desc with
+    Tvar name, Tvar name' ->
+      begin match name, name' with
+      | Some _, None ->  log_type ty'; ty'.desc <- Tvar name
+      | None, Some _ ->  ()
+      | Some _, Some _ ->
+          if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
+      | None, None   ->  ()
+      end
+  | _ -> ()
   (* ; assert (check_memorized_abbrevs ()) *)
   (*  ; check_expans [] ty' *)
 let set_level ty level =
@@ -481,6 +518,8 @@ let set_kind rk k =
   log_change (Ckind (rk, !rk)); rk := Some k
 let set_commu rc c =
   log_change (Ccommu (rc, !rc)); rc := c
+let set_typeset rs s =
+  log_change (Ctypeset (rs, !rs)); rs := s
 
 let snapshot () =
   let old = !last_snapshot in

diff --git a/typing/btype.mli b/typing/btype.mli
index 4ea5e3b40bbf86decf9c4e30d364af1efb527807..e2e4c9d6db1a4ebb8c81409985508c84f568b9eb 100644 (file)
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -17,13 +17,21 @@
 open Asttypes
 open Types
 
+(**** Sets, maps and hashtables of types ****)
+
+module TypeSet  : Set.S with type elt = type_expr
+module TypeMap  : Map.S with type key = type_expr
+module TypeHash : Hashtbl.S with type key = type_expr
+
+(**** Levels ****)
+
 val generic_level: int
 
 val newty2: int -> type_desc -> type_expr
         (* Create a type *)
 val newgenty: type_desc -> type_expr
         (* Create a generic type *)
-val newgenvar: unit -> type_expr
+val newgenvar: ?name:string -> unit -> type_expr
         (* Return a fresh generic variable *)
 
 (* Use Tsubst instead
@@ -33,6 +41,9 @@ val newmarkedgenvar: unit -> type_expr
         (* Return a fresh marked generic variable *)
 *)
 
+val is_Tvar: type_expr -> bool
+val is_Tunivar: type_expr -> bool
+
 val repr: type_expr -> type_expr
         (* Return the canonical representative of a type. *)
 
@@ -43,6 +54,8 @@ val field_kind_repr: field_kind -> field_kind
 val commu_repr: commutable -> commutable
         (* Return the canonical representative of a commutation lock *)
 
+(**** polymorphic variants ****)
+
 val row_repr: row_desc -> row_desc
         (* Return the canonical representative of a row description *)
 val row_field_repr: row_field -> row_field
@@ -150,6 +163,10 @@ val set_row_field: row_field option ref -> row_field -> unit
 val set_univar: type_expr option ref -> type_expr -> unit
 val set_kind: field_kind option ref -> field_kind -> unit
 val set_commu: commutable ref -> commutable -> unit
+val set_typeset: TypeSet.t ref -> TypeSet.t -> unit
         (* Set references, logging the old value *)
 val log_type: type_expr -> unit
         (* Log the old value of a type, before modifying it by hand *)
+
+(**** Forward declarations ****)
+val print_raw: (Format.formatter -> type_expr -> unit) ref

diff --git a/typing/ctype.ml b/typing/ctype.ml
index 356260b56e5f876accf7ab487b1232a36decc1dc..86d744ac99b89f6c758a20440c7f40fbc240018a 100644 (file)
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -95,6 +95,9 @@ exception Cannot_apply
 
 exception Recursive_abbrev
 
+(* GADT: recursive abbrevs can appear as a result of local constraints *)
+exception Unification_recursive_abbrev of (type_expr * type_expr) list
+
 (**** Type level management ****)
 
 let current_level = ref 0
@@ -102,6 +105,7 @@ let nongen_level = ref 0
 let global_level = ref 1
 let saved_level = ref []
 
+let get_current_level () = !current_level
 let init_def level = current_level := level; nongen_level := level
 let begin_def () =
   saved_level := (!current_level, !nongen_level) :: !saved_level;
@@ -136,9 +140,18 @@ let is_object_type path =
 
 (**** Abbreviations without parameters ****)
 (* Shall reset after generalizing *)
+
+let trace_gadt_instances = ref false
+let check_trace_gadt_instances env =
+  not !trace_gadt_instances && Env.has_local_constraints env &&
+  (trace_gadt_instances := true; cleanup_abbrev (); true)
+
 let simple_abbrevs = ref Mnil
+
 let proper_abbrevs path tl abbrev =
-  if !Clflags.principal || tl <> [] || is_object_type path then abbrev
+  if tl <> [] || !trace_gadt_instances || !Clflags.principal ||
+     is_object_type path
+  then abbrev
   else simple_abbrevs
 
 (**** Some type creators ****)
@@ -149,9 +162,9 @@ let newty2             = Btype.newty2
 let newty desc         = newty2 !current_level desc
 let new_global_ty desc = newty2 !global_level desc
 
-let newvar ()          = newty2 !current_level Tvar
-let newvar2 level      = newty2 level Tvar
-let new_global_var ()  = newty2 !global_level Tvar
+let newvar ?name ()         = newty2 !current_level (Tvar name)
+let newvar2 ?name level     = newty2 level (Tvar name)
+let new_global_var ?name () = newty2 !global_level (Tvar name)
 
 let newobj fields      = newty (Tobject (fields, ref None))
 
@@ -173,6 +186,48 @@ module TypePairs =
     let hash (t, t') = t.id + 93 * t'.id
  end)
 
+
+(**** unification mode ****)
+
+type unification_mode = 
+  | Expression (* unification in expression *)
+  | Pattern (* unification in pattern which may add local constraints *)
+
+let umode = ref Expression
+let generate_equations = ref false
+
+let set_mode mode ?(generate = (mode = Pattern)) f = 
+  let old_unification_mode = !umode
+  and old_gen = !generate_equations in
+  try
+    umode := mode;
+    generate_equations := generate;
+    let ret = f () in
+    umode := old_unification_mode;
+    generate_equations := old_gen;
+    ret
+  with e ->
+    umode := old_unification_mode;
+    generate_equations := old_gen;
+    raise e
+
+
+(*** Checks for type definitions ***)
+
+let in_current_module = function
+  | Path.Pident _ -> true
+  | Path.Pdot _ | Path.Papply _ -> false
+
+let in_pervasives p = 
+    try ignore (Env.find_type p Env.initial); true
+    with Not_found -> false
+        
+let is_datatype decl=
+  match decl.type_kind with
+    Type_record _ | Type_variant _ -> true
+  | Type_abstract -> false
+
+
                   (**********************************************)
                   (*  Miscellaneous operations on object types  *)
                   (**********************************************)
@@ -236,10 +291,13 @@ let rec object_row ty =
 
 let opened_object ty =
   match (object_row ty).desc with
-  | Tvar               -> true
-  | Tunivar            -> true
-  | Tconstr _          -> true
-  | _                  -> false
+  | Tvar _  | Tunivar _ | Tconstr _ -> true
+  | _                               -> false
+
+let concrete_object ty =
+  match (object_row ty).desc with
+  | Tvar _             -> false
+  | _                  -> true
 
 (**** Close an object ****)
 
@@ -247,7 +305,7 @@ let close_object ty =
   let rec close ty =
     let ty = repr ty in
     match ty.desc with
-      Tvar ->
+      Tvar _ ->
         link_type ty (newty2 ty.level Tnil)
     | Tfield(_, _, _, ty') -> close ty'
     | _                    -> assert false
@@ -263,7 +321,7 @@ let row_variable ty =
     let ty = repr ty in
     match ty.desc with
       Tfield (_, _, _, ty) -> find ty
-    | Tvar                 -> ty
+    | Tvar _               -> ty
     | _                    -> assert false
   in
   match (repr ty).desc with
@@ -368,7 +426,7 @@ let rec closed_schema_rec ty =
     let level = ty.level in
     ty.level <- pivot_level - level;
     match ty.desc with
-      Tvar when level <> generic_level ->
+      Tvar _ when level <> generic_level ->
         raise Non_closed
     | Tfield(_, kind, t1, t2) ->
         if field_kind_repr kind = Fpresent then
@@ -402,11 +460,11 @@ let rec free_vars_rec real ty =
   if ty.level >= lowest_level then begin
     ty.level <- pivot_level - ty.level;
     begin match ty.desc, !really_closed with
-      Tvar, _ ->
+      Tvar _, _ ->
         free_variables := (ty, real) :: !free_variables
     | Tconstr (path, tl, _), Some env ->
         begin try
-          let (_, body) = Env.find_type_expansion path env in
+          let (_, body, _) = Env.find_type_expansion path env in
           if (repr body).level <> generic_level then
             free_variables := (ty, real) :: !free_variables
         with Not_found -> ()
@@ -463,7 +521,13 @@ let closed_type_decl decl =
       Type_abstract ->
         ()
     | Type_variant v ->
-        List.iter (fun (_, tyl) -> List.iter closed_type tyl) v
+        List.iter 
+          (fun (_, tyl,ret_type_opt) ->
+            match ret_type_opt with
+            | Some _ -> ()
+            | None ->
+                List.iter closed_type tyl)
+          v 
     | Type_record(r, rep) ->
         List.iter (fun (_, _, ty) -> closed_type ty) r
     end;
@@ -567,14 +631,16 @@ let iterative_generalization min_level tyl =
 let rec generalize_structure var_level ty =
   let ty = repr ty in
   if ty.level <> generic_level then begin
-    if ty.desc = Tvar && ty.level > var_level then
+    if is_Tvar ty && ty.level > var_level then
       set_level ty var_level
-    else if ty.level > !current_level then begin
+    else if
+      ty.level > !current_level &&
+      match ty.desc with
+        Tconstr (p, _, abbrev) ->
+          not (is_object_type p) && (abbrev := Mnil; true)
+      | _ -> true
+    then begin
       set_level ty generic_level;
-      begin match ty.desc with
-        Tconstr (_, _, abbrev) -> abbrev := Mnil
-      | _ -> ()
-      end;
       iter_type_expr (generalize_structure var_level) ty
     end
   end
@@ -583,19 +649,27 @@ let generalize_structure var_level ty =
   simple_abbrevs := Mnil;
   generalize_structure var_level ty
 
-(* let generalize_expansive ty = generalize_structure !nongen_level ty *)
-let generalize_global ty = generalize_structure !global_level ty
-let generalize_structure ty = generalize_structure !current_level ty
-
 (* Generalize the spine of a function, if the level >= !current_level *)
 
 let rec generalize_spine ty =
   let ty = repr ty in
   if ty.level < !current_level || ty.level = generic_level then () else
   match ty.desc with
-    Tarrow (_, _, ty', _) | Tpoly (ty', _) ->
+    Tarrow (_, ty1, ty2, _) ->
+      set_level ty generic_level;
+      generalize_spine ty1;
+      generalize_spine ty2;
+  | Tpoly (ty', _) ->
       set_level ty generic_level;
       generalize_spine ty'
+  | Ttuple tyl
+  | Tpackage (_, _, tyl) ->
+      set_level ty generic_level;
+      List.iter generalize_spine tyl
+  | Tconstr (p, tyl, memo) when not (is_object_type p) ->
+      set_level ty generic_level;
+      memo := Mnil;
+      List.iter generalize_spine tyl
   | _ -> ()
 
 let forward_try_expand_once = (* Forward declaration *)
@@ -613,29 +687,47 @@ let forward_try_expand_once = (* Forward declaration *)
       module M = struct type t let _ = (x : t list ref) end
     (without this constraint, the type system would actually be unsound.)
 *)
+let get_level env p = 
+  try
+    match (Env.find_type p env).type_newtype_level with
+      | None -> Path.binding_time p
+      | Some (x, _) -> x
+  with 
+    | _ -> 
+      (* no newtypes in predef *)
+      Path.binding_time p
+
 let rec update_level env level ty =
   let ty = repr ty in
   if ty.level > level then begin
-    begin match ty.desc with
-      Tconstr(p, tl, abbrev)  when level < Path.binding_time p ->
+    if Env.has_local_constraints env then begin
+      match Env.gadt_instance_level env ty with
+        Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
+      | None -> ()
+    end;
+    match ty.desc with
+      Tconstr(p, tl, abbrev) when level < get_level env p ->
         (* Try first to replace an abbreviation by its expansion. *)
         begin try
+          (* if is_newtype env p then raise Cannot_expand; *)
           link_type ty (!forward_try_expand_once env ty);
           update_level env level ty
         with Cannot_expand ->
           (* +++ Levels should be restored... *)
-          raise (Unify [(ty, newvar2 level)])
+          (* Format.printf "update_level: %i < %i@." level (get_level env p); *)
+          if level < get_level env p then raise (Unify [(ty, newvar2 level)]);
+          iter_type_expr (update_level env level) ty
         end
-    | Tpackage (p, _, _) when level < Path.binding_time p ->
+    | Tpackage (p, _, _) when level < get_level env p ->
         raise (Unify [(ty, newvar2 level)])
     | Tobject(_, ({contents=Some(p, tl)} as nm))
-      when level < Path.binding_time p ->
+      when level < get_level env p ->
         set_name nm None;
         update_level env level ty
     | Tvariant row ->
         let row = row_repr row in
         begin match row.row_name with
-        | Some (p, tl) when level < Path.binding_time p ->
+        | Some (p, tl) when level < get_level env p ->
             log_type ty;
             ty.desc <- Tvariant {row with row_name = None}
         | _ -> ()
@@ -648,11 +740,13 @@ let rec update_level env level ty =
         set_level ty level;
         (* XXX what about abbreviations in Tconstr ? *)
         iter_type_expr (update_level env level) ty
-    end
   end
 
 (* Generalize and lower levels of contravariant branches simultaneously *)
 
+let generalize_contravariant env =
+  if !Clflags.principal then generalize_structure else update_level env
+
 let rec generalize_expansive env var_level ty =
   let ty = repr ty in
   if ty.level <> generic_level then begin
@@ -666,13 +760,13 @@ let rec generalize_expansive env var_level ty =
           abbrev := Mnil;
           List.iter2
             (fun (co,cn,ct) t ->
-              if ct then update_level env var_level t
+              if ct then generalize_contravariant env var_level t
               else generalize_expansive env var_level t)
             variance tyl
       | Tpackage (_, _, tyl) ->
-          List.iter (update_level env var_level) tyl
+          List.iter (generalize_contravariant env var_level) tyl
       | Tarrow (_, t1, t2, _) ->
-          update_level env var_level t1;
+          generalize_contravariant env var_level t1;
           generalize_expansive env var_level t2
       | _ ->
           iter_type_expr (generalize_expansive env var_level) ty
@@ -683,8 +777,11 @@ let generalize_expansive env ty =
   simple_abbrevs := Mnil;
   try
     generalize_expansive env !nongen_level ty
-  with Unify [_, ty'] ->
-    raise (Unify [ty, ty'])
+  with Unify ([_, ty'] as tr) ->
+    raise (Unify ((ty, ty') :: tr))
+
+let generalize_global ty = generalize_structure !global_level ty
+let generalize_structure ty = generalize_structure !current_level ty
 
 (* Correct the levels of type [ty]. *)
 let correct_levels ty =
@@ -738,6 +835,47 @@ let limited_generalize ty0 ty =
     graph
 
 
+(* Compute statically the free univars of all nodes in a type *)
+(* This avoids doing it repeatedly during instantiation *)
+
+type inv_type_expr =
+    { inv_type : type_expr;
+      mutable inv_parents : inv_type_expr list }
+
+let rec inv_type hash pty ty =
+  let ty = repr ty in
+  try
+    let inv = TypeHash.find hash ty in
+    inv.inv_parents <- pty @ inv.inv_parents
+  with Not_found ->
+    let inv = { inv_type = ty; inv_parents = pty } in
+    TypeHash.add hash ty inv;
+    iter_type_expr (inv_type hash [inv]) ty
+
+let compute_univars ty =
+  let inverted = TypeHash.create 17 in
+  inv_type inverted [] ty;
+  let node_univars = TypeHash.create 17 in
+  let rec add_univar univ inv =
+    match inv.inv_type.desc with
+      Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> ()
+    | _ ->
+        try
+          let univs = TypeHash.find node_univars inv.inv_type in
+          if not (TypeSet.mem univ !univs) then begin
+            univs := TypeSet.add univ !univs;
+            List.iter (add_univar univ) inv.inv_parents
+          end
+        with Not_found ->
+          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
+          List.iter (add_univar univ) inv.inv_parents
+  in
+  TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
+    inverted;
+  fun ty ->
+    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
+
+
                               (*******************)
                               (*  Instantiation  *)
                               (*******************)
@@ -767,15 +905,38 @@ let rec find_repr p1 =
 let abbreviations = ref (ref Mnil)
   (* Abbreviation memorized. *)
 
-let rec copy ty =
+(* partial: we may not wish to copy the non generic types
+   before we call type_pat *)
+let rec copy ?env ?partial ty =
+  let copy = copy ?env ?partial in
   let ty = repr ty in
   match ty.desc with
     Tsubst ty -> ty
   | _ ->
-    if ty.level <> generic_level then ty else
+    if ty.level <> generic_level && partial = None then ty else
+    (* We only forget types that are non generic and do not contain
+       free univars *)
+    let forget =
+      if ty.level = generic_level then generic_level else
+      match partial with
+        None -> assert false
+      | Some (free_univars, keep) ->
+          if TypeSet.is_empty (free_univars ty) then
+            if keep then ty.level else !current_level
+          else generic_level
+    in
+    if forget <> generic_level then newty2 forget (Tvar None) else
     let desc = ty.desc in
     save_desc ty desc;
     let t = newvar() in          (* Stub *)
+    begin match env with
+      Some env when Env.has_local_constraints env ->
+        begin match Env.gadt_instance_level env ty with
+          Some lv -> Env.add_gadt_instances env lv [t]
+        | None -> ()
+        end
+    | _ -> ()
+    end;
     ty.desc <- Tsubst t;
     t.desc <-
       begin match desc with
@@ -815,10 +976,10 @@ let rec copy ty =
               let more' =
                 match more.desc with
                   Tsubst ty -> ty
-                | Tconstr _ ->
+                | Tconstr _ | Tnil ->
                     if keep then save_desc more more.desc;
                     copy more
-                | Tvar | Tunivar ->
+                | Tvar _ | Tunivar _ ->
                     save_desc more more.desc;
                     if keep then more else newty more.desc
                 |  _ -> assert false
@@ -836,25 +997,86 @@ let rec copy ty =
               dup_kind r;
               copy_type_desc copy desc
           end
+      | Tobject (ty1, _) when partial <> None ->
+          Tobject (copy ty1, ref None)
       | _ -> copy_type_desc copy desc
       end;
     t
 
 (**** Variants of instantiations ****)
 
-let instance sch =
-  let ty = copy sch in
+let gadt_env env =
+  if Env.has_local_constraints env
+  then Some env
+  else None
+
+let instance ?partial env sch =
+  let env = gadt_env env in
+  let partial =
+    match partial with
+      None -> None
+    | Some keep -> Some (compute_univars sch, keep)
+  in
+  let ty = copy ?env ?partial sch in
   cleanup_types ();
   ty
 
-let instance_list schl =
-  let tyl = List.map copy schl in
+let instance_def sch =
+  let ty = copy sch in
+  cleanup_types ();
+  ty  
+
+let instance_list env schl =
+  let env = gadt_env env in
+  let tyl = List.map (copy ?env) schl in
   cleanup_types ();
   tyl
 
-let instance_constructor cstr =
+let reified_var_counter = ref Vars.empty
+    
+(* names given to new type constructors. 
+   Used for existential types and 
+   local constraints *)
+let get_new_abstract_name s =
+  let index =
+    try Vars.find s !reified_var_counter + 1
+    with Not_found -> 0 in
+  reified_var_counter := Vars.add s index !reified_var_counter;
+  Printf.sprintf "%s#%d" s index
+
+let new_declaration newtype manifest = 
+  {
+    type_params = [];
+    type_arity = 0;
+    type_kind = Type_abstract;
+    type_private = Public;
+    type_manifest = manifest;
+    type_variance = [];
+    type_newtype_level = newtype;
+    type_loc = Location.none;
+  }
+
+let instance_constructor ?in_pattern cstr =
   let ty_res = copy cstr.cstr_res in
   let ty_args = List.map copy cstr.cstr_args in
+  begin match in_pattern with
+  | None -> ()
+  | Some (env, newtype_lev) ->
+      let process existential = 
+        let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
+        let name =
+          match repr existential with
+            {desc = Tvar (Some name)} -> name
+          | _ -> "ex"
+        in
+        let (id, new_env) =
+          Env.enter_type (get_new_abstract_name name) decl !env in
+        env := new_env;
+        let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in 
+        link_type (copy existential) to_unify 
+      in
+      List.iter process cstr.cstr_existentials
+  end;
   cleanup_types ();
   (ty_args, ty_res)
 
@@ -878,7 +1100,9 @@ let instance_declaration decl =
      type_kind = match decl.type_kind with
      | Type_abstract -> Type_abstract
      | Type_variant cl ->
-         Type_variant (List.map (fun (s,tl) -> (s, List.map copy tl)) cl)
+         Type_variant (
+         List.map (fun (s,tl,ot) -> (s, List.map copy tl, may_map copy ot))
+           cl)
      | Type_record (fl, rr) ->
          Type_record (List.map (fun (s,m,ty) -> (s, m, copy ty)) fl, rr)}
   in
@@ -908,46 +1132,6 @@ let instance_class params cty =
 
 (**** Instanciation for types with free universal variables ****)
 
-module TypeHash = Hashtbl.Make(TypeOps)
-module TypeSet = Set.Make(TypeOps)
-
-type inv_type_expr =
-    { inv_type : type_expr;
-      mutable inv_parents : inv_type_expr list }
-
-let rec inv_type hash pty ty =
-  let ty = repr ty in
-  try
-    let inv = TypeHash.find hash ty in
-    inv.inv_parents <- pty @ inv.inv_parents
-  with Not_found ->
-    let inv = { inv_type = ty; inv_parents = pty } in
-    TypeHash.add hash ty inv;
-    iter_type_expr (inv_type hash [inv]) ty
-
-let compute_univars ty =
-  let inverted = TypeHash.create 17 in
-  inv_type inverted [] ty;
-  let node_univars = TypeHash.create 17 in
-  let rec add_univar univ inv =
-    match inv.inv_type.desc with
-      Tpoly (ty, tl) when List.memq univ (List.map repr tl) -> ()
-    | _ ->
-        try
-          let univs = TypeHash.find node_univars inv.inv_type in
-          if not (TypeSet.mem univ !univs) then begin
-            univs := TypeSet.add univ !univs;
-            List.iter (add_univar univ) inv.inv_parents
-          end
-        with Not_found ->
-          TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
-          List.iter (add_univar univ) inv.inv_parents
-  in
-  TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
-    inverted;
-  fun ty ->
-    try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
-
 let rec diff_list l1 l2 =
   if l1 == l2 then [] else
   match l1 with [] -> invalid_arg "Ctype.diff_list"
@@ -974,7 +1158,7 @@ let rec copy_sep fixed free bound visited ty =
     t
   else try
     let t, bound_t = List.assq ty visited in
-    let dl = if ty.desc = Tunivar then [] else diff_list bound bound_t in
+    let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
     if dl <> [] && conflicts univars dl then raise Not_found;
     t
   with Not_found -> begin
@@ -991,14 +1175,14 @@ let rec copy_sep fixed free bound visited ty =
           let row = row_repr row0 in
           let more = repr row.row_more in
           (* We shall really check the level on the row variable *)
-          let keep = more.desc = Tvar && more.level <> generic_level in
+          let keep = is_Tvar more && more.level <> generic_level in
           let more' = copy_rec more in
-          let fixed' = fixed && (repr more').desc = Tvar in
+          let fixed' = fixed && is_Tvar (repr more') in
           let row = copy_row copy_rec fixed' row keep more' in
           Tvariant row
       | Tpoly (t1, tl) ->
           let tl = List.map repr tl in
-          let tl' = List.map (fun t -> newty Tunivar) tl in
+          let tl' = List.map (fun t -> newty t.desc) tl in
           let bound = tl @ bound in
           let visited =
             List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
@@ -1008,9 +1192,15 @@ let rec copy_sep fixed free bound visited ty =
     t
   end
 
-let instance_poly fixed univars sch =
-  let vars = List.map (fun _ -> newvar ()) univars in
-  let pairs = List.map2 (fun u v -> repr u, (v, [])) univars vars in
+let instance_poly ?(keep_names=false) fixed univars sch =
+  let univars = List.map repr univars in
+  let copy_var ty =
+    match ty.desc with
+      Tunivar name -> if keep_names then newty (Tvar name) else newvar ()
+    | _ -> assert false
+  in
+  let vars = List.map copy_var univars in
+  let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in
   delayed_copy := [];
   let ty = copy_sep fixed (compute_univars sch) [] pairs sch in
   List.iter Lazy.force !delayed_copy;
@@ -1092,6 +1282,7 @@ let check_abbrev_env env =
     previous_env := env
   end
 
+
 (* Expand an abbreviation. The expansion is memorized. *)
 (*
    Assume the level is greater than the path binding time of the
@@ -1130,8 +1321,8 @@ let expand_abbrev_gen kind find_type_expansion env ty =
             end;
           ty
       | None ->
-          let (params, body) =
-            try find_type_expansion path env with Not_found ->
+          let (params, body, lv) =
+            try find_type_expansion level path env with Not_found ->
               raise Cannot_expand
           in
           (* prerr_endline
@@ -1143,12 +1334,26 @@ let expand_abbrev_gen kind find_type_expansion env ty =
               ty.desc <- Tvariant { row with row_name = Some (path, args) }
           | _ -> ()
           end;
+          (* For gadts, remember type as non exportable *)
+          if !trace_gadt_instances then begin
+            match lv with
+              Some lv ->
+                if level < lv then raise (Unify [(ty, newvar2 level)]);
+                Env.add_gadt_instances env lv [ty; ty']
+            | None ->
+                match Env.gadt_instance_level env ty with
+                  Some lv -> Env.add_gadt_instances env lv [ty']
+                | None -> ()
+          end;
           ty'
       end
   | _ ->
       assert false
 
-let expand_abbrev = expand_abbrev_gen Public Env.find_type_expansion
+(* inside objects and variants we do not want to 
+   use local constraints *)
+let expand_abbrev ty =
+  expand_abbrev_gen Public (fun level -> Env.find_type_expansion ~level) ty
 
 let safe_abbrev env ty =
   let snap = Btype.snapshot () in
@@ -1160,7 +1365,7 @@ let safe_abbrev env ty =
 let try_expand_once env ty =
   let ty = repr ty in
   match ty.desc with
-    Tconstr _ -> repr (expand_abbrev env ty)
+    Tconstr (p, _, _) -> repr (expand_abbrev env ty)
   | _ -> raise Cannot_expand
 
 let _ = forward_try_expand_once := try_expand_once
@@ -1170,11 +1375,16 @@ let _ = forward_try_expand_once := try_expand_once
    May raise Unify, if a recursion was hidden in the type. *)
 let rec try_expand_head env ty =
   let ty' = try_expand_once env ty in
-  begin try
-    try_expand_head env ty'
-  with Cannot_expand ->
-    ty'
-  end
+  let ty'' =
+    try try_expand_head env ty'
+    with Cannot_expand -> ty'
+  in
+  if Env.has_local_constraints env then begin
+    match Env.gadt_instance_level env ty'' with
+      None    -> ()
+    | Some lv -> Env.add_gadt_instance_chain env lv ty
+  end;
+  ty''
 
 (* Expand once the head of a type *)
 let expand_head_once env ty =
@@ -1198,7 +1408,8 @@ let expand_head env ty =
    normally hidden to the type-checker out of the implementation module of
    the private abbreviation. *)
 
-let expand_abbrev_opt = expand_abbrev_gen Private Env.find_type_expansion_opt
+let expand_abbrev_opt =
+  expand_abbrev_gen Private (fun level -> Env.find_type_expansion_opt)
 
 let try_expand_once_opt env ty =
   let ty = repr ty in
@@ -1238,7 +1449,7 @@ let enforce_constraints env ty =
 let rec full_expand env ty =
   let ty = repr (expand_head env ty) in
   match ty.desc with
-    Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar ->
+    Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
       newty2 ty.level (Tobject (fi, ref None))
   | _ ->
       ty
@@ -1250,7 +1461,7 @@ let rec full_expand env ty =
 *)
 let generic_abbrev env path =
   try
-    let (_, body) = Env.find_type_expansion path env in
+    let (_, body, _) = Env.find_type_expansion path env in
     (repr body).level = generic_level
   with
     Not_found ->
@@ -1277,8 +1488,11 @@ let rec non_recursive_abbrev env ty0 ty =
         begin try
           non_recursive_abbrev env ty0 (try_expand_once_opt env ty)
         with Cannot_expand ->
-          if !Clflags.recursive_types then () else
-          iter_type_expr (non_recursive_abbrev env ty0) ty
+          if !Clflags.recursive_types &&
+            (in_current_module p || in_pervasives p ||
+             is_datatype (Env.find_type p env))
+          then ()
+          else iter_type_expr (non_recursive_abbrev env ty0) ty
         end
     | Tobject _ | Tvariant _ ->
         ()
@@ -1344,6 +1558,31 @@ let occur env ty0 ty =
     merge type_changed old;
     raise (match exn with Occur -> Unify [] | _ -> exn)
 
+let occur_in env ty0 t =
+  try occur env ty0 t; false with Unify _ -> true
+
+(* checks that a local constraint is non recursive *)
+let rec local_non_recursive_abbrev visited env p ty =
+  let ty = repr ty in
+  if not (List.memq ty !visited) then begin
+    visited := ty :: !visited;
+    match ty.desc with
+      Tconstr(p', args, abbrev) ->
+        if Path.same p p' then raise Recursive_abbrev;
+        begin try
+          local_non_recursive_abbrev visited env p (try_expand_once_opt env ty)
+        with Cannot_expand ->
+          if !Clflags.recursive_types then () else
+          iter_type_expr (local_non_recursive_abbrev visited env p) ty
+        end
+    | Tobject _ | Tvariant _ ->
+        ()
+    | _ ->
+        if !Clflags.recursive_types then () else
+        iter_type_expr (local_non_recursive_abbrev visited env p) ty
+  end
+
+let local_non_recursive_abbrev = local_non_recursive_abbrev (ref [])
 
                    (*****************************)
                    (*  Polymorphic Unification  *)
@@ -1371,8 +1610,6 @@ let rec unify_univar t1 t2 = function
       end
   | [] -> raise (Unify [])
 
-module TypeMap = Map.Make (TypeOps)
-
 (* Test the occurence of free univars in a type *)
 (* that's way too expansive. Must do some kind of cacheing *)
 let occur_univar env ty =
@@ -1393,8 +1630,8 @@ let occur_univar env ty =
         true
     then
       match ty.desc with
-        Tunivar ->
-          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
+        Tunivar _ ->
+          if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()])
       | Tpoly (ty, tyl) ->
           let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
           occur_rec bound  ty
@@ -1443,7 +1680,7 @@ let univars_escape env univar_pairs vl ty =
         Tpoly (t, tl) ->
           if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
           else occur t
-      | Tunivar ->
+      | Tunivar _ ->
           if TypeSet.mem t family then raise Occur
       | Tconstr (_, [], _) -> ()
       | Tconstr (p, tl, _) ->
@@ -1553,60 +1790,348 @@ let deep_occur t0 ty =
       abbreviated.  It would be possible to check whether some
       information is indeed lost, but it probably does not worth it.
 *)
-let rec unify env t1 t2 =
-  (* First step: special cases (optimizations) *)
+
+let newtype_level = ref None
+
+let get_newtype_level () = 
+  match !newtype_level with
+  | None -> assert false
+  | Some x -> x
+
+(* a local constraint can be added only if the rhs 
+   of the constraint does not contain any Tvars.
+   They need to be removed using this function *)
+let reify env t =
+  let newtype_level = get_newtype_level () in
+  let create_fresh_constr lev name = 
+    let decl = new_declaration (Some (newtype_level, newtype_level)) None in
+    let name = get_new_abstract_name name in
+    let (id, new_env) = Env.enter_type name decl !env in    
+    let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil))  in 
+    env := new_env;
+    t
+  in
+  let visited = ref TypeSet.empty in
+  let rec iterator ty = 
+    let ty = repr ty in
+    if TypeSet.mem ty !visited then () else begin
+      visited := TypeSet.add ty !visited;
+      match ty.desc with
+        Tvar o ->
+          let name = match o with Some s -> s | _ -> "ex" in
+          let t = create_fresh_constr ty.level name in
+          link_type ty t
+      | Tvariant r ->
+          if not (static_row r) then iterator (row_more r);
+          iter_row iterator r
+      | Tconstr (p, _, _) when is_object_type p ->
+          iter_type_expr iterator (full_expand !env ty)
+      | _ ->
+          iter_type_expr iterator ty
+    end
+  in
+  iterator t
+
+let is_abstract_newtype env p = 
+  let decl = Env.find_type p env in 
+  not (decl.type_newtype_level = None) &&
+  decl.type_manifest = None &&
+  decl.type_kind = Type_abstract
+
+(* mcomp type_pairs subst env t1 t2 does not raise an 
+   exception if it is possible that t1 and t2 are actually
+   equal, assuming the types in type_pairs are equal and 
+   that the mapping subst holds. 
+   Assumes that both t1 and t2 do not contain any tvars
+   and that both their objects and variants are closed
+ *)
+
+let rec mcomp type_pairs subst env t1 t2 =
   if t1 == t2 then () else
   let t1 = repr t1 in
   let t2 = repr t2 in
   if t1 == t2 then () else
+    match (t1.desc, t2.desc) with
+      | (Tvar _, _)  
+      | (_, Tvar _)  ->
+        fatal_error "types should not include variables"
+      | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+        ()
+      | _ ->
+        let t1' = expand_head_opt env t1 in
+        let t2' = expand_head_opt env t2 in
+        (* Expansion may have changed the representative of the types... *)
+        let t1' = repr t1' and t2' = repr t2' in
+        if t1' == t2' then () else
+          begin try TypePairs.find type_pairs (t1', t2')
+          with Not_found ->
+              TypePairs.add type_pairs (t1', t2') ();
+              match (t1'.desc, t2'.desc) with
+                  (Tvar _, Tvar _) -> assert false
+                | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _))
+                  when l1 = l2 || not (is_optional l1 || is_optional l2) ->
+                  mcomp type_pairs subst env t1 t2;
+                  mcomp type_pairs subst env u1 u2;
+                | (Ttuple tl1, Ttuple tl2) ->
+                  mcomp_list type_pairs subst env tl1 tl2
+                | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) ->
+                  mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2
+                | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+                  when Path.same p1 p2 && n1 = n2 ->
+                  mcomp_list type_pairs subst env tl1 tl2
+                | (Tvariant row1, Tvariant row2) ->
+                  mcomp_row type_pairs subst env row1 row2
+                | (Tobject (fi1, _), Tobject (fi2, _)) ->
+                  mcomp_fields type_pairs subst env fi1 fi2
+                | (Tfield _, Tfield _) ->       (* Actually unused *)
+                  mcomp_fields type_pairs subst env t1' t2'
+                | (Tnil, Tnil) ->
+                  ()
+                | (Tpoly (t1, []), Tpoly (t2, [])) ->
+                  mcomp type_pairs subst env t1 t2
+                | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+                  enter_poly env univar_pairs t1 tl1 t2 tl2
+                    (mcomp type_pairs subst env)
+                | (Tunivar _, Tunivar _) ->
+                  unify_univar t1' t2' !univar_pairs
+                | (_, _) ->
+                  raise (Unify [])
+          end
+
+and mcomp_list type_pairs subst env tl1 tl2 =
+  if List.length tl1 <> List.length tl2 then
+    raise (Unify []);
+  List.iter2 (mcomp type_pairs subst env) tl1 tl2
+
+and mcomp_fields type_pairs subst env ty1 ty2 =
+  if not (concrete_object ty1 && concrete_object ty2) then assert false;
+  let (fields2, rest2) = flatten_fields ty2 in
+  let (fields1, rest1) = flatten_fields ty1 in
+  let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+  mcomp type_pairs subst env rest1 rest2;
+  if miss1 <> []  && (object_row ty1).desc = Tnil
+  || miss2 <> []  && (object_row ty2).desc = Tnil then raise (Unify []);
+  List.iter
+    (function (n, k1, t1, k2, t2) ->
+       mcomp_kind k1 k2;
+       mcomp type_pairs subst env t1 t2)
+    pairs
 
+and mcomp_kind k1 k2 =
+  let k1 = field_kind_repr k1 in
+  let k2 = field_kind_repr k2 in
+  match k1, k2 with
+    (Fvar _, Fvar _)
+  | (Fpresent, Fpresent) -> ()
+  | _                    -> raise (Unify [])
+
+and mcomp_row type_pairs subst env row1 row2 =
+  let row1 = row_repr row1 and row2 = row_repr row2 in
+  let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
+  let cannot_erase (_,f) =
+    match row_field_repr f with
+      Rpresent _ -> true
+    | Rabsent | Reither _ -> false
+  in
+  if row1.row_closed && List.exists cannot_erase r2
+  || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []);
+  List.iter
+    (fun (_,f1,f2) ->
+      match row_field_repr f1, row_field_repr f2 with
+      | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent)
+      | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent)
+      | (Reither (_, _::_, _, _) | Rabsent), Rpresent None
+      | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) ->
+          raise (Unify [])
+      | Rpresent(Some t1), Rpresent(Some t2) ->
+          mcomp type_pairs subst env t1 t2
+      | Rpresent(Some t1), Reither(false, tl2, _, _) ->
+          List.iter (mcomp type_pairs subst env t1) tl2
+      | Reither(false, tl1, _, _), Rpresent(Some t2) ->
+          List.iter (mcomp type_pairs subst env t2) tl1
+      | _ -> ())
+    pairs
+
+and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = 
+  let non_aliased p decl =
+    in_pervasives p ||
+    in_current_module p && decl.type_newtype_level = None
+  in
+  let decl = Env.find_type p1 env in
+  let decl' = Env.find_type p2 env in
+  if Path.same p1 p2 then
+    if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2 else ()
+  else match decl.type_kind, decl'.type_kind with
+  | Type_record (lst,r), Type_record (lst',r') when r = r' ->
+      mcomp_list type_pairs subst env tl1 tl2;
+      mcomp_record_description type_pairs subst env lst lst'
+  | Type_variant v1, Type_variant v2 ->
+      mcomp_list type_pairs subst env tl1 tl2;
+      mcomp_variant_description type_pairs subst env v1 v2
+  | Type_variant _, Type_record _
+  | Type_record _, Type_variant _ -> raise (Unify [])
+  | _ ->
+      if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl')
+      || is_datatype decl && non_aliased p2 decl' then raise (Unify [])
+
+and mcomp_type_option type_pairs subst env t t' = 
+  match t, t' with
+    None, None -> ()
+  | Some t, Some t' -> mcomp type_pairs subst env t t' 
+  | _ -> raise (Unify []) 
+
+and mcomp_variant_description type_pairs subst env = 
+  let rec iter = fun x y ->
+    match x, y with
+    (name,mflag,t) :: xs, (name', mflag', t') :: ys   ->
+      mcomp_type_option type_pairs subst env t t';
+      if name = name' && mflag = mflag' 
+      then iter xs ys
+      else raise (Unify [])
+    | [],[] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter
+
+and mcomp_record_description type_pairs subst env = 
+  let rec iter = fun x y ->
+    match x, y with 
+      (name, mutable_flag, t) :: xs, (name', mutable_flag', t') :: ys ->
+        mcomp type_pairs subst env t t';
+        if name = name' && mutable_flag = mutable_flag' 
+        then iter xs ys
+        else raise (Unify [])
+    | [], [] -> ()
+    | _ -> raise (Unify [])
+  in
+  iter
+
+let mcomp env t1 t2 =
+  mcomp (TypePairs.create 4) () env t1 t2
+
+(* Real unification *)
+
+let find_lowest_level ty =
+  let lowest = ref generic_level in
+  let rec find ty =
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      if ty.level < !lowest then lowest := ty.level;
+      ty.level <- pivot_level - ty.level;
+      iter_type_expr find ty
+    end
+  in find ty; unmark_type ty; !lowest
+
+let find_newtype_level env path = 
+  match (Env.find_type path env).type_newtype_level with
+    Some x -> x
+  | None -> assert false
+        
+let add_gadt_equation env source destination =
+  let destination = duplicate_type destination in 
+  let source_lev = find_newtype_level !env (Path.Pident source) in
+  let decl = new_declaration (Some source_lev) (Some destination) in
+  let newtype_level = get_newtype_level () in
+  env := Env.add_local_constraint source decl newtype_level !env;
+  cleanup_abbrev ()          
+
+let unify_eq_set = TypePairs.create 11
+
+let order_type_pair t1 t2 =
+  if t1.id <= t2.id then (t1, t2) else (t2, t1)
+
+let add_type_equality t1 t2 = 
+  TypePairs.add unify_eq_set (order_type_pair t1 t2) ()
+        
+let unify_eq env t1 t2 =
+  t1 == t2 ||
+  match !umode with
+  | Expression -> false
+  | Pattern ->
+      try TypePairs.find unify_eq_set (order_type_pair t1 t2); true
+      with Not_found -> false
+
+let rec unify (env:Env.t ref) t1 t2 =
+  (* First step: special cases (optimizations) *)
+  if unify_eq !env t1 t2 then () else
+  let t1 = repr t1 in
+  let t2 = repr t2 in
+  if unify_eq !env t1 t2 then () else
+  let reset_tracing = check_trace_gadt_instances !env in
+  
   try
     type_changed := true;
-    match (t1.desc, t2.desc) with
-      (Tvar, Tconstr _) when deep_occur t1 t2 ->
+    begin match (t1.desc, t2.desc) with
+      (Tvar _, Tconstr _) when deep_occur t1 t2 ->
         unify2 env t1 t2
-    | (Tconstr _, Tvar) when deep_occur t2 t1 ->
+    | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
         unify2 env t1 t2
-    | (Tvar, _) ->
-        occur env t1 t2; occur_univar env t2;
-        update_level env t1.level t2;
-        link_type t1 t2
-    | (_, Tvar) ->
-        occur env t2 t1; occur_univar env t1;
-        update_level env t2.level t1;
-        link_type t2 t1
-    | (Tunivar, Tunivar) ->
+    | (Tvar _, _) ->
+        occur !env t1 t2; 
+        occur_univar !env t2;
+        link_type t1 t2;
+        update_level !env t1.level t2
+    | (_, Tvar _) ->
+        occur !env t2 t1; 
+        occur_univar !env t1;
+        link_type t2 t1;
+        update_level !env t2.level t1
+    | (Tunivar _, Tunivar _) ->
         unify_univar t1 t2 !univar_pairs;
-        update_level env t1.level t2;
+        update_level !env t1.level t2;
         link_type t1 t2
     | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
-          when Path.same p1 p2
+          when Path.same p1 p2 (* && actual_mode !env = Old *)
             (* This optimization assumes that t1 does not expand to t2
                (and conversely), so we fall back to the general case
                when any of the types has a cached expansion. *)
             && not (has_cached_expansion p1 !a1
                  || has_cached_expansion p2 !a2) ->
-        update_level env t1.level t2;
+        update_level !env t1.level t2;
         link_type t1 t2
     | _ ->
         unify2 env t1 t2
+    end;
+    if reset_tracing then trace_gadt_instances := false;
   with Unify trace ->
+    if reset_tracing then trace_gadt_instances := false;
     raise (Unify ((t1, t2)::trace))
 
 and unify2 env t1 t2 =
   (* Second step: expansion of abbreviations *)
   let rec expand_both t1'' t2'' =
-    let t1' = expand_head_unif env t1 in
-    let t2' = expand_head_unif env t2 in
+    let t1' = expand_head_unif !env t1 in
+    let t2' = expand_head_unif !env t2 in
     (* Expansion may have changed the representative of the types... *)
-    if t1' == t1'' && t2' == t2'' then (t1',t2') else
+    if unify_eq !env t1' t1'' && unify_eq !env t2' t2'' then (t1',t2') else
     expand_both t1' t2'
   in
   let t1', t2' = expand_both t1 t2 in
-  if t1' == t2' then () else
+  let lv = min t1'.level t2'.level in
+  update_level !env lv t2;
+  update_level !env lv t1;
+  if unify_eq !env t1' t2' then () else
 
   let t1 = repr t1 and t2 = repr t2 in
-  if (t1 == t1') || (t2 != t2') then
+  if !trace_gadt_instances then begin
+    match Env.gadt_instance_level !env t1',Env.gadt_instance_level !env t2' with
+      Some lv1, Some lv2 ->
+        if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
+        if lv2 > lv2 then Env.add_gadt_instance_chain !env lv2 t1
+    | Some lv1, None -> Env.add_gadt_instance_chain !env lv1 t2
+    | None, Some lv2 -> Env.add_gadt_instance_chain !env lv2 t1
+    | None, None     -> ()
+  end;
+  let t1, t2 =
+    if !Clflags.principal
+    && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then
+      (* Expand abbreviations hiding a lower level *)
+      (* Should also do it for parameterized types, after unification... *)
+      (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1),
+      (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2)
+    else (t1, t2)
+  in
+  if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then
     unify3 env t1 t1' t2 t2'
   else
     try unify3 env t2 t2' t1 t1' with Unify trace ->
@@ -1616,132 +2141,151 @@ and unify3 env t1 t1' t2 t2' =
   (* Third step: truly unification *)
   (* Assumes either [t1 == t1'] or [t2 != t2'] *)
   let d1 = t1'.desc and d2 = t2'.desc in
-
   let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
-  occur env t1' t2;
-  update_level env t1'.level t2;
-  link_type t1' t2;
-
-  try
-    begin match (d1, d2) with
-      (Tvar, _) ->
-        occur_univar env t2
-    | (_, Tvar) ->
-        let td1 = newgenty d1 in
-        occur env t2' td1;
-        occur_univar env td1;
-        if t1 == t1' then begin
-          (* The variable must be instantiated... *)
-          let ty = newty2 t1'.level d1 in
-          update_level env t2'.level ty;
-          link_type t2' ty
-        end else begin
-          log_type t1';
-          t1'.desc <- d1;
-          update_level env t2'.level t1;
-          link_type t2' t1
-        end
-    | (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
-      || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
-        unify env t1 t2; unify env u1 u2;
-        begin match commu_repr c1, commu_repr c2 with
-          Clink r, c2 -> set_commu r c2
-        | c1, Clink r -> set_commu r c1
-        | _ -> ()
-        end
-    | (Ttuple tl1, Ttuple tl2) ->
-        unify_list env tl1 tl2
-    | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
-        unify_list env tl1 tl2
-    | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
-        unify_fields env fi1 fi2;
-        (* Type [t2'] may have been instantiated by [unify_fields] *)
-        (* XXX One should do some kind of unification... *)
-        begin match (repr t2').desc with
-          Tobject (_, {contents = Some (_, va::_)})
-          when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
-            ()
-        | Tobject (_, nm2) ->
-            set_name nm2 !nm1
-        | _ ->
-            ()
-        end
-    | (Tvariant row1, Tvariant row2) ->
-        unify_row env row1 row2
-    | (Tfield _, Tfield _) ->           (* Actually unused *)
-        unify_fields env t1' t2'
-    | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
-        begin match field_kind_repr kind with
-          Fvar r when f <> dummy_method -> set_kind r Fabsent
-        | _      -> raise (Unify [])
-        end
-    | (Tnil, Tnil) ->
-        ()
-    | (Tpoly (t1, []), Tpoly (t2, [])) ->
-        unify env t1 t2
-    | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
-        enter_poly env univar_pairs t1 tl1 t2 tl2 (unify env)
-    | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 ->
-        unify_list env tl1 tl2
-    | (_, _) ->
-        raise (Unify [])
-    end;
-
-(* XXX Commentaires + changer "create_recursion" *)
-    if create_recursion then begin
-      match t2.desc with
-        Tconstr (p, tl, abbrev) ->
-          forget_abbrev abbrev p;
-          let t2'' = expand_head_unif env t2 in
-          if not (closed_parameterized_type tl t2'') then
-            link_type (repr t2) (repr t2')
-      | _ ->
-          () (* t2 has already been expanded by update_level *)
-    end
 
-(*
-    (*
-       Can only be done afterwards, once the row variable has
-       (possibly) been instantiated.
-    *)
-    if t1 != t1' (* && t2 != t2' *) then begin
-      match (t1.desc, t2.desc) with
-        (Tconstr (p, ty::_, _), _)
-            when ((repr ty).desc <> Tvar)
-              && weak_abbrev p
-              && not (deep_occur t1 t2) ->
-          update_level env t1.level t2;
-          link_type t1 t2
-      | (_, Tconstr (p, ty::_, _))
-            when ((repr ty).desc <> Tvar)
-              && weak_abbrev p
-              && not (deep_occur t2 t1) ->
-          update_level env t2.level t1;
-          link_type t2 t1;
-          link_type t1' t2'
-      | _ ->
+  begin match (d1, d2) with (* handle vars and univars specially *)
+    (Tunivar _, Tunivar _) ->
+      unify_univar t1' t2' !univar_pairs;
+      link_type t1' t2'
+  | (Tvar _, _) ->
+      occur !env t1 t2';
+      occur_univar !env t2;
+      link_type t1' t2;
+  | (_, Tvar _) ->
+      occur !env t2 t1';
+      occur_univar !env t1;
+      link_type t2' t1;
+  | (Tfield _, Tfield _) -> (* special case for GADTs *)
+      unify_fields env t1' t2'
+  | _ ->
+      begin match !umode with
+      | Expression ->
+          occur !env t1' t2';
+          link_type t1' t2
+      | Pattern ->
+          add_type_equality t1' t2'
+      end;
+      try match (d1, d2) with
+        (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 ||
+        !Clflags.classic && not (is_optional l1 || is_optional l2) ->
+          unify  env t1 t2; unify env  u1 u2;
+          begin match commu_repr c1, commu_repr c2 with
+            Clink r, c2 -> set_commu r c2
+          | c1, Clink r -> set_commu r c1
+          | _ -> ()
+          end
+      | (Ttuple tl1, Ttuple tl2) ->
+          unify_list env tl1 tl2
+      | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+          if !umode = Expression || not !generate_equations
+          || in_current_module p1 || in_pervasives p1
+          || is_datatype (Env.find_type p1 !env)
+          then
+            unify_list env tl1 tl2
+          else
+            set_mode Pattern ~generate:false (fun () -> unify_list env tl1 tl2)
+      | (Tconstr ((Path.Pident p) as path,[],_),
+         Tconstr ((Path.Pident p') as path',[],_))
+        when is_abstract_newtype !env path && is_abstract_newtype !env path'
+        && !generate_equations ->
+          let source,destination =
+            if find_newtype_level !env path > find_newtype_level !env path'
+            then  p,t2'
+            else  p',t1'
+          in add_gadt_equation env source destination
+      | (Tconstr ((Path.Pident p) as path,[],_), _)
+        when is_abstract_newtype !env path && !generate_equations ->
+          reify env t2';
+          local_non_recursive_abbrev !env (Path.Pident p) t2';
+          add_gadt_equation env p t2'
+      | (_, Tconstr ((Path.Pident p) as path,[],_))
+        when is_abstract_newtype !env path && !generate_equations ->
+          reify env t1' ;
+          local_non_recursive_abbrev !env (Path.Pident p) t1';
+          add_gadt_equation env p t1'
+      | (Tconstr (_,[],_), _) | (_, Tconstr (_,[],_)) when !umode = Pattern ->
+          reify env t1';
+          reify env t2';
+          mcomp !env t1' t2'
+      | (Tobject (fi1, nm1), Tobject (fi2, _)) ->
+          unify_fields env fi1 fi2;
+          (* Type [t2'] may have been instantiated by [unify_fields] *)
+          (* XXX One should do some kind of unification... *)
+          begin match (repr t2').desc with
+            Tobject (_, {contents = Some (_, va::_)}) when
+              (match (repr va).desc with
+                Tvar _|Tunivar _|Tnil -> true | _ -> false) -> ()
+          | Tobject (_, nm2) -> set_name nm2 !nm1
+          | _ -> ()
+          end
+      | (Tvariant row1, Tvariant row2) ->
+          unify_row env row1 row2
+      | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
+          begin match field_kind_repr kind with
+            Fvar r when f <> dummy_method ->
+              set_kind r Fabsent;
+              if d2 = Tnil then unify env rem t2'
+              else unify env (newty2 rem.level Tnil) rem
+          | _      -> raise (Unify [])
+          end
+      | (Tnil, Tnil) ->
           ()
-    end
-*)
-  with Unify trace ->
-    t1'.desc <- d1;
-    raise (Unify trace)
+      | (Tpoly (t1, []), Tpoly (t2, [])) ->
+          unify env t1 t2
+      | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+          enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env)
+      | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+        when Path.same p1 p2 && n1 = n2 ->
+          unify_list env tl1 tl2
+      | (_, _) ->
+          raise (Unify [])
+      with Unify trace ->
+        t1'.desc <- d1;
+        raise (Unify trace)
+  end;
+  (* XXX Commentaires + changer "create_recursion" *)
+  if create_recursion then begin
+    match t2.desc with
+      Tconstr (p, tl, abbrev) ->
+        forget_abbrev abbrev p;
+        let t2'' = expand_head_unif !env t2 in
+        if not (closed_parameterized_type tl t2'') then
+          link_type (repr t2) (repr t2')
+    | _ ->
+        () (* t2 has already been expanded by update_level *)
+  end
 
 and unify_list env tl1 tl2 =
   if List.length tl1 <> List.length tl2 then
     raise (Unify []);
   List.iter2 (unify env) tl1 tl2
 
+(* Build a fresh row variable for unification *)
+and make_rowvar level use1 rest1 use2 rest2  =
+  let set_name ty name =
+    match ty.desc with
+      Tvar None -> log_type ty; ty.desc <- Tvar name
+    | _ -> ()
+  in
+  let name =
+    match rest1.desc, rest2.desc with
+      Tvar (Some _ as name1), Tvar (Some _ as name2) ->
+        if rest1.level <= rest2.level then name1 else name2
+    | Tvar (Some _ as name), _ ->
+        if use2 then set_name rest2 name; name
+    | _, Tvar (Some _ as name) ->
+        if use1 then set_name rest2 name; name
+    | _ -> None
+  in
+  if use1 then rest1 else
+  if use2 then rest2 else newvar2 ?name level
+
 and unify_fields env ty1 ty2 =          (* Optimization *)
   let (fields1, rest1) = flatten_fields ty1
   and (fields2, rest2) = flatten_fields ty2 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
   let l1 = (repr ty1).level and l2 = (repr ty2).level in
-  let va =
-    if miss1 = [] then rest2
-    else if miss2 = [] then rest1
-    else newty2 (min l1 l2) Tvar
-  in
+  let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
   let d1 = rest1.desc and d2 = rest2.desc in
   try
     unify env (build_fields l1 miss1 va) rest2;
@@ -1749,9 +2293,12 @@ and unify_fields env ty1 ty2 =          (* Optimization *)
     List.iter
       (fun (n, k1, t1, k2, t2) ->
         unify_kind k1 k2;
-        try unify env t1 t2 with Unify trace ->
-          raise (Unify ((newty (Tfield(n, k1, t1, va)),
-                         newty (Tfield(n, k2, t2, va)))::trace)))
+        try 
+          if !trace_gadt_instances then update_level !env va.level t1;
+          unify env t1 t2 
+        with Unify trace ->
+          raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)),
+                         newty (Tfield(n, k2, t2, newty Tnil)))::trace)))
       pairs
   with exn ->
     log_type rest1; rest1.desc <- d1;
@@ -1768,13 +2315,13 @@ and unify_kind k1 k2 =
   | (Fpresent, Fpresent)          -> ()
   | _                             -> assert false
 
-and unify_pairs env tpl =
+and unify_pairs mode env tpl =
   List.iter (fun (t1, t2) -> unify env t1 t2) tpl
 
 and unify_row env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let rm1 = row_more row1 and rm2 = row_more row2 in
-  if rm1 == rm2 then () else
+  if unify_eq !env rm1 rm2 then () else
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   if r1 <> [] && r2 <> [] then begin
     let ht = Hashtbl.create (List.length r1) in
@@ -1788,8 +2335,7 @@ and unify_row env row1 row2 =
   let more =
     if row1.row_fixed then rm1 else
     if row2.row_fixed then rm2 else
-    newgenvar ()
-  in update_level env (min rm1.level rm2.level) more;
+    newty2 (min rm1.level rm2.level) (Tvar None) in
   let fixed = row1.row_fixed || row2.row_fixed
   and closed = row1.row_closed || row2.row_closed in
   let keep switch =
@@ -1829,14 +2375,17 @@ and unify_row env row1 row2 =
       let t1 = mkvariant [] true and t2 = mkvariant rest false in
       raise (Unify [if row == row1 then (t1,t2) else (t2,t1)])
     end;
+    (* The following test is not principal... should rather use Tnil *)
     let rm = row_more row in
+    if !trace_gadt_instances && rm.desc = Tnil then () else
+    if !trace_gadt_instances then
+      update_level !env rm.level (newgenty (Tvariant row));
     if row.row_fixed then
-      if row0.row_more == rm then () else
-      if rm.desc = Tvar then link_type rm row0.row_more else
-      unify env rm row0.row_more
+      if more == rm then () else
+      if is_Tvar rm then link_type rm more else unify env rm more
     else
-      let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in
-      update_level env rm.level ty;
+      let ty = newgenty (Tvariant {row0 with row_fields = rest}) in
+      update_level !env rm.level ty;
       link_type rm ty
   in
   let md1 = rm1.desc and md2 = rm2.desc in
@@ -1879,7 +2428,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
       in
       let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
       (* Is this handling of levels really principal? *)
-      List.iter (update_level env (repr more).level) (tl1' @ tl2');
+      List.iter (update_level !env (repr more).level) (tl1' @ tl2');
       let e = ref None in
       let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
       and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
@@ -1889,10 +2438,12 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
   | Rabsent, Rabsent -> ()
   | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
       set_row_field e1 f2;
+      update_level !env (repr more).level t2;
       (try List.iter (fun t1 -> unify env t1 t2) tl
       with exn -> e1 := None; raise exn)
   | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
       set_row_field e2 f1;
+      update_level !env (repr more).level t1;
       (try List.iter (unify env t1) tl
       with exn -> e2 := None; raise exn)
   | Reither(true, [], _, e1), Rpresent None when not fixed1 ->
@@ -1905,23 +2456,43 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
 let unify env ty1 ty2 =
   try
     unify env ty1 ty2
-  with Unify trace ->
-    raise (Unify (expand_trace env trace))
+  with
+    Unify trace ->
+      raise (Unify (expand_trace !env trace))
+  | Recursive_abbrev ->
+      raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)]))
+
+let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 =
+  try
+    univar_pairs := [];
+    newtype_level := Some lev;
+    set_mode Pattern (fun () -> unify env ty1 ty2);
+    newtype_level := None;
+    TypePairs.clear unify_eq_set;
+  with e ->
+    TypePairs.clear unify_eq_set;
+    match e with
+      Unify e -> raise (Unify e)
+    | e -> newtype_level := None; raise e
 
 let unify_var env t1 t2 =
   let t1 = repr t1 and t2 = repr t2 in
   if t1 == t2 then () else
   match t1.desc with
-    Tvar ->
+    Tvar _ ->
+      let reset_tracing = check_trace_gadt_instances env in
       begin try
         occur env t1 t2;
         update_level env t1.level t2;
-        link_type t1 t2
+        link_type t1 t2;
+        if reset_tracing then trace_gadt_instances := false;
       with Unify trace ->
-        raise (Unify (expand_trace env ((t1,t2)::trace)))
+        if reset_tracing then trace_gadt_instances := false;
+        let expanded_trace = expand_trace env ((t1,t2)::trace) in 
+        raise (Unify expanded_trace)
       end
   | _ ->
-      unify env t1 t2
+      unify (ref env) t1 t2
 
 let _ = unify' := unify_var
 
@@ -1930,25 +2501,32 @@ let unify_pairs env ty1 ty2 pairs =
   unify env ty1 ty2
 
 let unify env ty1 ty2 =
-  univar_pairs := [];
-  unify env ty1 ty2
+  unify_pairs (ref env) ty1 ty2 []
+
 
 
 (**** Special cases of unification ****)
 
+let expand_head_trace env t =
+  let reset_tracing = check_trace_gadt_instances env in
+  let t = expand_head_unif env t in
+  if reset_tracing then trace_gadt_instances := false;
+  t
+
 (*
    Unify [t] and [l:'a -> 'b]. Return ['a] and ['b].
    In label mode, label mismatch is accepted when
    (1) the requested label is ""
    (2) the original label is not optional
 *)
+
 let rec filter_arrow env t l =
-  let t = expand_head_unif env t in
+  let t = expand_head_trace env t in
   match t.desc with
-    Tvar ->
-      let t1 = newvar () and t2 = newvar () in
-      let t' = newty (Tarrow (l, t1, t2, Cok)) in
-      update_level env t.level t';
+    Tvar _ ->
+      let lv = t.level in
+      let t1 = newvar2 lv and t2 = newvar2 lv in
+      let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
       link_type t t';
       (t1, t2)
   | Tarrow(l', t1, t2, _)
@@ -1959,9 +2537,9 @@ let rec filter_arrow env t l =
 
 (* Used by [filter_method]. *)
 let rec filter_method_field env name priv ty =
-  let ty = repr ty in
+  let ty = expand_head_trace env ty in
   match ty.desc with
-    Tvar ->
+    Tvar _ ->
       let level = ty.level in
       let ty1 = newvar2 level and ty2 = newvar2 level in
       let ty' = newty2 level (Tfield (name,
@@ -1986,9 +2564,9 @@ let rec filter_method_field env name priv ty =
 
 (* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *)
 let rec filter_method env name priv ty =
-  let ty = expand_head_unif env ty in
+  let ty = expand_head_trace env ty in
   match ty.desc with
-    Tvar ->
+    Tvar _ ->
       let ty1 = newvar () in
       let ty' = newobj ty1 in
       update_level env ty.level ty';
@@ -2024,7 +2602,7 @@ let moregen_occur env level ty =
   let rec occur ty =
     let ty = repr ty in
     if ty.level > level then begin
-      if ty.desc = Tvar && ty.level >= generic_level - 1 then raise Occur;
+      if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
       ty.level <- pivot_level - ty.level;
       match ty.desc with
         Tvariant row when static_row row ->
@@ -2054,9 +2632,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
 
   try
     match (t1.desc, t2.desc) with
-      (Tunivar, Tunivar) ->
-        unify_univar t1 t2 !univar_pairs
-    | (Tvar, _) when may_instantiate inst_nongen t1 ->
+      (Tvar _, _) when may_instantiate inst_nongen t1 ->
         moregen_occur env t1.level t2;
         occur env t1 t2;
         link_type t1 t2
@@ -2073,7 +2649,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
         with Not_found ->
           TypePairs.add type_pairs (t1', t2') ();
           match (t1'.desc, t2'.desc) with
-            (Tvar, _) when may_instantiate inst_nongen t1' ->
+            (Tvar _, _) when may_instantiate inst_nongen t1' ->
               moregen_occur env t1'.level t2;
               link_type t1' t2
           | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
@@ -2085,7 +2661,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
           | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
                 when Path.same p1 p2 ->
               moregen_list inst_nongen type_pairs env tl1 tl2
-          | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) when Path.same p1 p2 && n1 = n2 ->
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+            when Path.same p1 p2 && n1 = n2 ->
               moregen_list inst_nongen type_pairs env tl1 tl2
           | (Tvariant row1, Tvariant row2) ->
               moregen_row inst_nongen type_pairs env row1 row2
@@ -2100,6 +2677,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
           | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
               enter_poly env univar_pairs t1 tl1 t2 tl2
                 (moregen inst_nongen type_pairs env)
+          | (Tunivar _, Tunivar _) ->
+              unify_univar t1' t2' !univar_pairs
           | (_, _) ->
               raise (Unify [])
         end
@@ -2139,7 +2718,8 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
   if rm1 == rm2 then () else
-  let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in
+  let may_inst =
+    is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   let r1, r2 =
     if row2.row_closed then
@@ -2149,9 +2729,9 @@ and moregen_row inst_nongen type_pairs env row1 row2 =
   if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
   then raise (Unify []);
   begin match rm1.desc, rm2.desc with
-    Tunivar, Tunivar ->
+    Tunivar _, Tunivar _ ->
       unify_univar rm1 rm2 !univar_pairs
-  | Tunivar, _ | _, Tunivar ->
+  | Tunivar _, _ | _, Tunivar _ ->
       raise (Unify [])
   | _ when static_row row1 -> ()
   | _ when may_inst ->
@@ -2221,10 +2801,10 @@ let moregeneral env inst_nongen pat_sch subj_sch =
      then copied with [duplicate_type].  That way, its levels won't be
      changed.
   *)
-  let subj = duplicate_type (instance subj_sch) in
+  let subj = duplicate_type (instance env subj_sch) in
   current_level := generic_level;
   (* Duplicate generic variables *)
-  let patt = instance pat_sch in
+  let patt = instance env pat_sch in
   let res =
     try moregen inst_nongen (TypePairs.create 13) env patt subj; true with
       Unify _ -> false
@@ -2242,13 +2822,13 @@ let rec rigidify_rec vars ty =
   if ty.level >= lowest_level then begin
     ty.level <- pivot_level - ty.level;
     match ty.desc with
-    | Tvar ->
+    | Tvar _ ->
         if not (List.memq ty !vars) then vars := ty :: !vars
     | Tvariant row ->
         let row = row_repr row in
         let more = repr row.row_more in
-        if more.desc = Tvar && not row.row_fixed then begin
-          let more' = newty2 more.level Tvar in
+        if is_Tvar more && not row.row_fixed then begin
+          let more' = newty2 more.level more.desc in
           let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
           in link_type more (newty2 ty.level (Tvariant row'))
         end;
@@ -2271,7 +2851,7 @@ let all_distinct_vars env vars =
     (fun ty ->
       let ty = expand_head env ty in
       if List.memq ty !tyl then false else
-      (tyl := ty :: !tyl; ty.desc = Tvar))
+      (tyl := ty :: !tyl; is_Tvar ty))
     vars
 
 let matches env ty ty' =
@@ -2290,6 +2870,11 @@ let matches env ty ty' =
                  (*  Equivalence between parameterized types  *)
                  (*********************************************)
 
+let rec get_object_row ty =
+  match repr ty with
+  | {desc=Tfield (_, _, _, tl)} -> get_object_row tl
+  | ty -> ty
+
 let expand_head_rigid env ty =
   let old = !rigid_variants in
   rigid_variants := true;
@@ -2310,7 +2895,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
 
   try
     match (t1.desc, t2.desc) with
-      (Tvar, Tvar) when rename ->
+      (Tvar _, Tvar _) when rename ->
         begin try
           normalize_subst subst;
           if List.assq t1 !subst != t2 then raise (Unify [])
@@ -2331,12 +2916,13 @@ let rec eqtype rename type_pairs subst env t1 t2 =
         with Not_found ->
           TypePairs.add type_pairs (t1', t2') ();
           match (t1'.desc, t2'.desc) with
-            (Tvar, Tvar) when rename ->
+            (Tvar _, Tvar _) when rename ->
               begin try
                 normalize_subst subst;
                 if List.assq t1' !subst != t2' then raise (Unify [])
               with Not_found ->
-                if List.exists (fun (_, t) -> t == t2') !subst then raise (Unify []);
+                if List.exists (fun (_, t) -> t == t2') !subst
+                then raise (Unify []);
                 subst := (t1', t2') :: !subst
               end
           | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
@@ -2348,7 +2934,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
           | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
                 when Path.same p1 p2 ->
               eqtype_list rename type_pairs subst env tl1 tl2
-          | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) when Path.same p1 p2 && n1 = n2 ->
+          | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2))
+            when Path.same p1 p2 && n1 = n2 ->
               eqtype_list rename type_pairs subst env tl1 tl2
           | (Tvariant row1, Tvariant row2) ->
               eqtype_row rename type_pairs subst env row1 row2
@@ -2363,7 +2950,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
           | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
               enter_poly env univar_pairs t1 tl1 t2 tl2
                 (eqtype rename type_pairs subst env)
-          | (Tunivar, Tunivar) ->
+          | (Tunivar _, Tunivar _) ->
               unify_univar t1' t2' !univar_pairs
           | (_, _) ->
               raise (Unify [])
@@ -2377,12 +2964,18 @@ and eqtype_list rename type_pairs subst env tl1 tl2 =
   List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
 
 and eqtype_fields rename type_pairs subst env ty1 ty2 =
+  let (fields1, rest1) = flatten_fields ty1 in
   let (fields2, rest2) = flatten_fields ty2 in
+  (* First check if same row => already equal *)
+  let same_row =
+    rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
+    (rename && List.mem (rest1, rest2) !subst)
+  in
+  if same_row then () else
   (* Try expansion, needed when called from Includecore.type_manifest *)
   match expand_head_rigid env rest2 with
     {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
   | _ ->
-  let (fields1, rest1) = flatten_fields ty1 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
   eqtype rename type_pairs subst env rest1 rest2;
   if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
@@ -2782,16 +3375,16 @@ let rec filter_visited = function
 let memq_warn t visited =
   if List.memq t visited then (warn := true; true) else false
 
-let rec lid_of_path sharp = function
+let rec lid_of_path ?(sharp="") = function
     Path.Pident id ->
       Longident.Lident (sharp ^ Ident.name id)
   | Path.Pdot (p1, s, _) ->
-      Longident.Ldot (lid_of_path "" p1, sharp ^ s)
+      Longident.Ldot (lid_of_path p1, sharp ^ s)
   | Path.Papply (p1, p2) ->
-      Longident.Lapply (lid_of_path sharp p1, lid_of_path "" p2)
+      Longident.Lapply (lid_of_path ~sharp p1, lid_of_path p2)
 
 let find_cltype_for_path env p =
-  let path, cl_abbr = Env.lookup_type (lid_of_path "#" p) env in
+  let path, cl_abbr = Env.lookup_type (lid_of_path ~sharp:"#" p) env in
   match cl_abbr.type_manifest with
     Some ty ->
       begin match (repr ty).desc with
@@ -2806,7 +3399,7 @@ let has_constr_row' env t =
 let rec build_subtype env visited loops posi level t =
   let t = repr t in
   match t.desc with
-    Tvar ->
+    Tvar _ ->
       if posi then
         try
           let t' = List.assq t loops in
@@ -2855,13 +3448,13 @@ let rec build_subtype env visited loops posi level t =
              as this occurence might break the occur check.
              XXX not clear whether this correct anyway... *)
           if List.exists (deep_occur ty) tl1 then raise Not_found;
-          ty.desc <- Tvar;
+          ty.desc <- Tvar None;
           let t'' = newvar () in
           let loops = (ty, t'') :: loops in
           (* May discard [visited] as level is going down *)
           let (ty1', c) =
             build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
-          assert (t''.desc = Tvar);
+          assert (is_Tvar t'');
           let nm =
             if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
           t''.desc <- Tobject (ty1', ref nm);
@@ -2960,7 +3553,7 @@ let rec build_subtype env visited loops posi level t =
       let (t1', c) = build_subtype env visited loops posi level t1 in
       if c > Unchanged then (newty (Tpoly(t1', tl)), c)
       else (t, Unchanged)
-  | Tunivar | Tpackage _ ->
+  | Tunivar _ | Tpackage _ ->
       (t, Unchanged)
 
 let enlarge_type env ty =
@@ -2996,6 +3589,23 @@ let private_abbrev env path =
     decl.type_private = Private && decl.type_manifest <> None
   with Not_found -> false
 
+(* check list inclusion, assuming lists are ordered *)
+let rec included nl1 nl2 =
+  match nl1, nl2 with
+    (a::nl1', b::nl2') ->
+      if a = b then included nl1' nl2' else
+      a > b && included nl1 nl2'
+  | ([], _) -> true
+  | (_, []) -> false
+
+let rec extract_assoc nl1 nl2 tl2 =
+  match (nl1, nl2, tl2) with
+    (a::nl1', b::nl2, t::tl2) ->
+      if a = b then t :: extract_assoc nl1' nl2 tl2
+      else extract_assoc nl1 nl2 tl2
+  | ([], _, _) -> []
+  | _ -> assert false
+
 let rec subtype_rec env trace t1 t2 cstrs =
   let t1 = repr t1 in
   let t2 = repr t2 in
@@ -3007,7 +3617,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
   with Not_found ->
     TypePairs.add subtypes (t1, t2) ();
     match (t1.desc, t2.desc) with
-      (Tvar, _) | (_, Tvar) ->
+      (Tvar _, _) | (_, Tvar _) ->
         (trace, t1, t2, !univar_pairs)::cstrs
     | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
       || !Clflags.classic && not (is_optional l1 || is_optional l2) ->
@@ -3043,7 +3653,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
     | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 ->
         subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
     | (Tobject (f1, _), Tobject (f2, _))
-      when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar ->
+      when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
         (* Same row variable implies same object. *)
         (trace, t1, t2, !univar_pairs)::cstrs
     | (Tobject (f1, _), Tobject (f2, _)) ->
@@ -3066,6 +3676,11 @@ let rec subtype_rec env trace t1 t2 cstrs =
         with Unify _ ->
           (trace, t1, t2, !univar_pairs)::cstrs
         end
+    | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2))
+      when Path.same p1 p2 && included nl2 nl1 ->
+        List.map2 (fun t1 t2 -> (trace, t1, t2, !univar_pairs))
+          (extract_assoc nl2 nl1 tl1) tl2
+        @ cstrs
     | (_, _) ->
         (trace, t1, t2, !univar_pairs)::cstrs
   end
@@ -3110,7 +3725,7 @@ and subtype_row env trace row1 row2 cstrs =
   match more1.desc, more2.desc with
     Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
       subtype_rec env ((more1,more2)::trace) more1 more2 cstrs
-  | (Tvar|Tconstr _), (Tvar|Tconstr _)
+  | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil)
     when row1.row_closed && r1 = [] ->
       List.fold_left
         (fun cstrs (_,f1,f2) ->
@@ -3124,7 +3739,7 @@ and subtype_row env trace row1 row2 cstrs =
           | Rabsent, _ -> cstrs
           | _ -> raise Exit)
         cstrs pairs
-  | Tunivar, Tunivar
+  | Tunivar _, Tunivar _
     when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
       let cstrs =
         subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in
@@ -3153,7 +3768,7 @@ let subtype env ty1 ty2 =
   function () ->
     List.iter
       (function (trace0, t1, t2, pairs) ->
-         try unify_pairs env t1 t2 pairs with Unify trace ->
+         try unify_pairs (ref env) t1 t2 pairs with Unify trace ->
            raise (Subtype (expand_trace env (List.rev trace0),
                            List.tl (List.tl trace))))
       (List.rev cstrs)
@@ -3168,19 +3783,19 @@ let rec unalias_object ty =
   match ty.desc with
     Tfield (s, k, t1, t2) ->
       newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
-  | Tvar | Tnil ->
+  | Tvar _ | Tnil ->
       newty2 ty.level ty.desc
-  | Tunivar ->
+  | Tunivar _ ->
       ty
   | Tconstr _ ->
-      newty2 ty.level Tvar
+      newvar2 ty.level
   | _ ->
       assert false
 
 let unalias ty =
   let ty = repr ty in
   match ty.desc with
-    Tvar | Tunivar ->
+    Tvar _ | Tunivar _ ->
       ty
   | Tvariant row ->
       let row = row_repr row in
@@ -3254,7 +3869,7 @@ let rec normalize_type_rec env visited ty =
               set_name nm None
             else let v' = repr v in
             begin match v'.desc with
-            | Tvar|Tunivar ->
+            | Tvar _ | Tunivar _ ->
                 if v' != v then set_name nm (Some (n, v' :: l))
             | Tnil ->
                 log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
@@ -3296,7 +3911,7 @@ let clear_hash ()   =
 
 let rec nondep_type_rec env id ty =
   match ty.desc with
-    Tvar | Tunivar -> ty
+    Tvar _ | Tunivar _ -> ty
   | Tlink ty -> nondep_type_rec env id ty
   | _ -> try TypeHash.find nondep_hash ty
   with Not_found ->
@@ -3342,7 +3957,7 @@ let rec nondep_type_rec env id ty =
             (* Register new type first for recursion *)
             TypeHash.add nondep_variants more ty';
             let static = static_row row in
-            let more' = if static then newgenvar () else more in
+            let more' = if static then newgenty Tnil else more in
             (* Return a new copy *)
             let row =
               copy_row (nondep_type_rec env id) true row true more' in
@@ -3366,7 +3981,7 @@ let nondep_type env id ty =
 
 let unroll_abbrev id tl ty =
   let ty = repr ty and path = Path.Pident id in
-  if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl)
+  if is_Tvar ty || (List.exists (deep_occur ty) tl)
   || is_object_type path then
     ty
   else
@@ -3385,7 +4000,11 @@ let nondep_type_decl env mid id is_covariant decl =
       | Type_variant cstrs ->
           Type_variant
             (List.map
-               (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl))
+               (fun (c, tl,ret_type_opt) -> 
+                 let ret_type_opt = 
+                   may_map (nondep_type_rec env mid) ret_type_opt
+                 in
+                 (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) 
                cstrs)
       | Type_record(lbls, rep) ->
           Type_record
@@ -3414,6 +4033,8 @@ let nondep_type_decl env mid id is_covariant decl =
       type_manifest = tm;
       type_private = priv;
       type_variance = decl.type_variance;
+      type_newtype_level = None;
+      type_loc = decl.type_loc;
     }
   with Not_found ->
     clear_hash ();

diff --git a/typing/ctype.mli b/typing/ctype.mli
index d7a401841f0576c2b8f27f3bd886614d6970c5c6..c4d4ff13a3d0843f98ba2776033be3ab67b3d982 100644 (file)
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,6 +24,7 @@ exception Subtype of
 exception Cannot_expand
 exception Cannot_apply
 exception Recursive_abbrev
+exception Unification_recursive_abbrev of (type_expr * type_expr) list
 
 val init_def: int -> unit
         (* Set the initial variable level *)
@@ -40,9 +41,10 @@ val restore_global_level: int -> unit
         (* This pair of functions is only used in Typetexp *)
 
 val newty: type_desc -> type_expr
-val newvar: unit -> type_expr
+val newvar: ?name:string -> unit -> type_expr
+val newvar2: ?name:string -> int -> type_expr
         (* Return a fresh variable *)
-val new_global_var: unit -> type_expr
+val new_global_var: ?name:string -> unit -> type_expr
         (* Return a fresh variable, bound at toplevel
            (as type variables ['a] in type constraints). *)
 val newobj: type_expr -> type_expr
@@ -74,6 +76,7 @@ val set_object_name:
 val remove_object_name: type_expr -> unit
 val hide_private_methods: type_expr -> unit
 val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr
+val lid_of_path: ?sharp:string -> Path.t -> Longident.t
 
 val sort_row_fields: (label * row_field) list -> (label * row_field) list
 val merge_row_fields:
@@ -103,11 +106,17 @@ val limited_generalize: type_expr -> type_expr -> unit
         (* Only generalize some part of the type
            Make the remaining of the type non-generalizable *)
 
-val instance: type_expr -> type_expr
+val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
         (* Take an instance of a type scheme *)
-val instance_list: type_expr list -> type_expr list
+        (* partial=None  -> normal
+           partial=false -> newvar() for non generic subterms
+           partial=true  -> newty2 ty.level Tvar for non generic subterms *)
+val instance_def: type_expr -> type_expr
+        (* use defaults *)
+val instance_list: Env.t -> type_expr list -> type_expr list
         (* Take an instance of a list of type schemes *)
 val instance_constructor:
+        ?in_pattern:Env.t ref * int -> 
         constructor_description -> type_expr list * type_expr
         (* Same, for a constructor *)
 val instance_parameterized_type:
@@ -119,6 +128,7 @@ val instance_declaration: type_declaration -> type_declaration
 val instance_class:
         type_expr list -> class_type -> type_expr list * class_type
 val instance_poly:
+        ?keep_names:bool ->
         bool -> type_expr list -> type_expr -> type_expr list * type_expr
         (* Take an instance of a type scheme containing free univars *)
 val instance_label:
@@ -142,6 +152,8 @@ val enforce_constraints: Env.t -> type_expr -> unit
 
 val unify: Env.t -> type_expr -> type_expr -> unit
         (* Unify the two types given. Raise [Unify] if not possible. *)
+val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
+        (* Unify the two types given and update the environment with the local constraints. Raise [Unify] if not possible. *)
 val unify_var: Env.t -> type_expr -> type_expr -> unit
         (* Same as [unify], but allow free univars when first type
            is a variable. *)
@@ -151,6 +163,7 @@ val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr
         (* A special case of unification (with {m : 'a; 'b}). *)
 val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit
         (* A special case of unification (with {m : 'a; 'b}), returning unit. *)
+val occur_in: Env.t -> type_expr -> type_expr -> bool
 val deep_occur: type_expr -> type_expr -> bool
 val filter_self_method:
         Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref ->
@@ -244,3 +257,5 @@ val arity: type_expr -> int
 
 val collapse_conj_params: Env.t -> type_expr list -> unit
         (* Collapse conjunctive types in class parameters *)
+
+val get_current_level: unit -> int

diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 80b94132d96c2f5e261a47be84da59d84fa74bac..bc05d2a845a89847d5e2855e6992706702f32d62 100644 (file)
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -18,41 +18,85 @@
 open Misc
 open Asttypes
 open Types
+open Btype
+
+(* Simplified version of Ctype.free_vars *)
+let rec free_vars ty =
+  let ret = ref TypeSet.empty in
+  let rec loop ty = 
+    let ty = repr ty in
+    if ty.level >= lowest_level then begin
+      ty.level <- pivot_level - ty.level;
+      match ty.desc with
+      | Tvar _ ->
+          ret := TypeSet.add ty !ret
+      | Tvariant row ->
+          let row = row_repr row in
+          iter_row loop row;
+          if not (static_row row) then loop row.row_more
+      | _ ->
+         iter_type_expr loop ty
+    end
+  in
+  loop ty;
+  unmark_type ty;
+  !ret
 
 let constructor_descrs ty_res cstrs priv =
-  let num_consts = ref 0 and num_nonconsts = ref 0 in
+  let num_consts = ref 0 and num_nonconsts = ref 0  and num_normal = ref 0 in
   List.iter
-    (function (name, []) -> incr num_consts
-            | (name, _)  -> incr num_nonconsts)
+    (fun (name, args, ret) ->
+      if args = [] then incr num_consts else incr num_nonconsts;
+      if ret = None then incr num_normal)
     cstrs;
   let rec describe_constructors idx_const idx_nonconst = function
       [] -> []
-    | (name, ty_args) :: rem ->
+    | (name, ty_args, ty_res_opt) :: rem ->
+       let ty_res = 
+         match ty_res_opt with
+         | Some ty_res' -> ty_res'
+         | None -> ty_res
+       in
         let (tag, descr_rem) =
           match ty_args with
             [] -> (Cstr_constant idx_const,
                    describe_constructors (idx_const+1) idx_nonconst rem)
           | _  -> (Cstr_block idx_nonconst,
                    describe_constructors idx_const (idx_nonconst+1) rem) in
-        let cstr =
-          { cstr_res = ty_res;
+       let existentials = 
+         match ty_res_opt with
+         | None -> []
+         | Some type_ret ->
+             let res_vars = free_vars type_ret in
+             let arg_vars = free_vars (newgenty (Ttuple ty_args)) in
+             TypeSet.elements (TypeSet.diff arg_vars res_vars)
+       in
+       let cstr =
+          { cstr_res = ty_res;    
+           cstr_existentials = existentials; 
             cstr_args = ty_args;
             cstr_arity = List.length ty_args;
             cstr_tag = tag;
             cstr_consts = !num_consts;
             cstr_nonconsts = !num_nonconsts;
-            cstr_private = priv } in
+           cstr_normal = !num_normal;
+            cstr_private = priv;
+           cstr_generalized = ty_res_opt <> None
+         } in
         (name, cstr) :: descr_rem in
-  describe_constructors 0 0 cstrs
+  describe_constructors 0 0 cstrs 
 
 let exception_descr path_exc decl =
   { cstr_res = Predef.type_exn;
-    cstr_args = decl;
-    cstr_arity = List.length decl;
-    cstr_tag = Cstr_exception path_exc;
+    cstr_existentials = [];
+    cstr_args = decl.exn_args;
+    cstr_arity = List.length decl.exn_args;
+    cstr_tag = Cstr_exception (path_exc, decl.exn_loc);
     cstr_consts = -1;
     cstr_nonconsts = -1;
-    cstr_private = Public }
+    cstr_private = Public;
+    cstr_normal = -1;
+    cstr_generalized = false }
 
 let none = {desc = Ttuple []; level = -1; id = -1}
                                         (* Clearly ill-formed type *)
@@ -84,13 +128,13 @@ exception Constr_not_found
 let rec find_constr tag num_const num_nonconst = function
     [] ->
       raise Constr_not_found
-  | (name, [] as cstr) :: rem ->
+  | (name, ([] as cstr),(_ as ret_type_opt)) :: rem ->
       if tag = Cstr_constant num_const
-      then cstr
+      then (name,cstr,ret_type_opt)
       else find_constr tag (num_const + 1) num_nonconst rem
-  | (name, _ as cstr) :: rem ->
+  | (name, (_ as cstr),(_ as ret_type_opt)) :: rem ->
       if tag = Cstr_block num_nonconst
-      then cstr
+      then (name,cstr,ret_type_opt)
       else find_constr tag num_const (num_nonconst + 1) rem
 
 let find_constr_by_tag tag cstrlist =

diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index 283dbd294a1e1fc3a69e7f4e8ecc03305709dcf3..bc1190d4540715aa46cb02b854c4d3c6539e22cf 100644 (file)
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,10 +19,10 @@ open Asttypes
 open Types
 
 val constructor_descrs:
-  type_expr -> (string * type_expr list) list -> private_flag ->
-    (string * constructor_description) list
+  type_expr -> (string * type_expr list * type_expr option) list ->
+  private_flag -> (string * constructor_description) list
 val exception_descr:
-  Path.t -> type_expr list -> constructor_description
+  Path.t -> exception_declaration -> constructor_description
 val label_descrs:
   type_expr -> (string * mutable_flag * type_expr) list ->
     record_representation -> private_flag ->
@@ -31,4 +31,5 @@ val label_descrs:
 exception Constr_not_found
 
 val find_constr_by_tag:
-  constructor_tag -> (string * type_expr list) list -> string * type_expr list
+  constructor_tag -> (string * type_expr list * type_expr option) list ->
+    string * type_expr list * type_expr option

diff --git a/typing/env.ml b/typing/env.ml
index 6eb558552828a3f9a78ae57f159261cef9a592b3..7ec2028b6449935e2a675d93afacc65acbf28eee 100644 (file)
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -20,10 +20,37 @@ open Asttypes
 open Longident
 open Path
 open Types
-
+open Btype
+
+let add_delayed_check_forward = ref (fun _ -> assert false)
+
+let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = Hashtbl.create 16
+    (* This table is used to usage of value declarations.  A declaration is
+       identified with its name and location.  The callback attached to a declaration
+       is called whenever the value is used explicitly (lookup_value) or implicitly
+       (inclusion test between signatures, cf Includemod.value_descriptions). *)
+
+let type_declarations = Hashtbl.create 16
+
+type constructor_usage = [`Positive|`Pattern|`Privatize]
+type constructor_usages =
+    {
+     mutable cu_positive: bool;
+     mutable cu_pattern: bool;
+     mutable cu_privatize: bool;
+    }
+let add_constructor_usage cu = function
+  | `Positive -> cu.cu_positive <- true
+  | `Pattern -> cu.cu_pattern <- true
+  | `Privatize -> cu.cu_privatize <- true
+let constructor_usages () =
+  {cu_positive = false; cu_pattern = false; cu_privatize = false}
+
+let used_constructors : (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t = Hashtbl.create 16
 
 type error =
     Not_an_interface of string
+  | Wrong_version_interface of string * string
   | Corrupted_interface of string
   | Illegal_renaming of string * string
   | Inconsistent_import of string * string * string
@@ -42,18 +69,57 @@ type summary =
   | Env_cltype of summary * Ident.t * cltype_declaration
   | Env_open of summary * Path.t
 
+module EnvTbl =
+  struct
+    (* A table indexed by identifier, with an extra slot to record usage. *)
+    type 'a t = 'a Ident.tbl * bool ref Ident.tbl
+
+    let empty = (Ident.empty, Ident.empty)
+    let current_slot = ref (ref true)
+
+    let add id x (tbl, slots) =
+      let slot = !current_slot in
+      let slots = if !slot then slots else Ident.add id slot slots in
+      Ident.add id x tbl, slots
+
+    let find_same_not_using id (tbl, _) =
+      Ident.find_same id tbl
+
+    let find_same id (tbl, slots) =
+      (try Ident.find_same id slots := true with Not_found -> ());
+      Ident.find_same id tbl
+
+    let find_name s (tbl, slots) =
+      (try Ident.find_name s slots := true with Not_found -> ());
+      Ident.find_name s tbl
+
+    let with_slot slot f x =
+      let old_slot = !current_slot in
+      current_slot := slot;
+      try_finally
+        (fun () -> f x)
+        (fun () -> current_slot := old_slot)
+
+    let keys (tbl, _) =
+      Ident.keys tbl
+  end
+
 type t = {
-  values: (Path.t * value_description) Ident.tbl;
-  annotations: (Path.t * Annot.ident) Ident.tbl;
-  constrs: constructor_description Ident.tbl;
-  labels: label_description Ident.tbl;
-  types: (Path.t * type_declaration) Ident.tbl;
-  modules: (Path.t * module_type) Ident.tbl;
-  modtypes: (Path.t * modtype_declaration) Ident.tbl;
-  components: (Path.t * module_components) Ident.tbl;
-  classes: (Path.t * class_declaration) Ident.tbl;
-  cltypes: (Path.t * cltype_declaration) Ident.tbl;
-  summary: summary
+  values: (Path.t * value_description) EnvTbl.t;
+  annotations: (Path.t * Annot.ident) EnvTbl.t;
+  constrs: constructor_description EnvTbl.t;
+  labels: label_description EnvTbl.t;
+  constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t;
+  types: (Path.t * type_declaration) EnvTbl.t;
+  modules: (Path.t * module_type) EnvTbl.t;
+  modtypes: (Path.t * modtype_declaration) EnvTbl.t;
+  components: (Path.t * module_components) EnvTbl.t;
+  classes: (Path.t * class_declaration) EnvTbl.t;
+  cltypes: (Path.t * cltype_declaration) EnvTbl.t;
+  summary: summary;
+  local_constraints: bool;
+  gadt_instances: (int * TypeSet.t ref) list;
+  in_signature: bool;
 }
 
 and module_components = module_components_repr Lazy.t
@@ -67,6 +133,8 @@ and structure_components = {
   mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t;
   mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
   mutable comp_labels: (string, (label_description * int)) Tbl.t;
+  mutable comp_constrs_by_path: 
+      (string, (constructor_description list * int)) Tbl.t;
   mutable comp_types: (string, (type_declaration * int)) Tbl.t;
   mutable comp_modules: (string, (module_type Lazy.t * int)) Tbl.t;
   mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t;
@@ -85,19 +153,24 @@ and functor_components = {
 }
 
 let empty = {
-  values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty;
-  labels = Ident.empty; types = Ident.empty;
-  modules = Ident.empty; modtypes = Ident.empty;
-  components = Ident.empty; classes = Ident.empty;
-  cltypes = Ident.empty;
-  summary = Env_empty }
+  values = EnvTbl.empty; annotations = EnvTbl.empty; constrs = EnvTbl.empty;
+  labels = EnvTbl.empty; types = EnvTbl.empty; 
+  constrs_by_path = EnvTbl.empty;
+  modules = EnvTbl.empty; modtypes = EnvTbl.empty;
+  components = EnvTbl.empty; classes = EnvTbl.empty;
+  cltypes = EnvTbl.empty; 
+  summary = Env_empty; local_constraints = false; gadt_instances = [];
+  in_signature = false;
+ }
+
+let in_signature env = {env with in_signature = true}
 
 let diff_keys is_local tbl1 tbl2 =
-  let keys2 = Ident.keys tbl2 in
+  let keys2 = EnvTbl.keys tbl2 in
   List.filter
     (fun id ->
-      is_local (Ident.find_same id tbl2) &&
-      try ignore (Ident.find_same id tbl1); false with Not_found -> true)
+      is_local (EnvTbl.find_same_not_using id tbl2) &&
+      try ignore (EnvTbl.find_same_not_using id tbl1); false with Not_found -> true)
     keys2
 
 let is_ident = function
@@ -107,7 +180,7 @@ let is_ident = function
 let is_local (p, _) = is_ident p
 
 let is_local_exn = function
-    {cstr_tag = Cstr_exception p} -> is_ident p
+    {cstr_tag = Cstr_exception (p, _)} -> is_ident p
   | _ -> false
 
 let diff env1 env2 =
@@ -147,7 +220,7 @@ type pers_struct =
     ps_flags: pers_flags list }
 
 let persistent_structures =
-  (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t)
+  (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t)
 
 (* Consistency between persistent structures *)
 
@@ -166,11 +239,17 @@ let check_consistency filename crcs =
 let read_pers_struct modname filename =
   let ic = open_in_bin filename in
   try
-    let buffer = String.create (String.length cmi_magic_number) in
-    really_input ic buffer 0 (String.length cmi_magic_number);
+    let buffer = Misc.input_bytes ic (String.length cmi_magic_number) in
     if buffer <> cmi_magic_number then begin
       close_in ic;
-      raise(Error(Not_an_interface filename))
+      let pre_len = String.length cmi_magic_number - 3 in
+      if String.sub buffer 0 pre_len = String.sub cmi_magic_number 0 pre_len then
+      begin
+        let msg = if buffer < cmi_magic_number then "an older" else "a newer" in
+         raise (Error (Wrong_version_interface (filename, msg)))
+      end else begin
+        raise(Error(Not_an_interface filename))
+      end
     end;
     let (name, sign) = input_value ic in
     let crcs = input_value ic in
@@ -194,22 +273,40 @@ let read_pers_struct modname filename =
         if not !Clflags.recursive_types then
           raise(Error(Need_recursive_types(ps.ps_name, !current_unit))))
       ps.ps_flags;
-    Hashtbl.add persistent_structures modname ps;
+    Hashtbl.add persistent_structures modname (Some ps);
     ps
   with End_of_file | Failure _ ->
     close_in ic;
     raise(Error(Corrupted_interface(filename)))
 
 let find_pers_struct name =
-  try
-    Hashtbl.find persistent_structures name
-  with Not_found ->
-    read_pers_struct name (find_in_path_uncap !load_path (name ^ ".cmi"))
+  if name = "*predef*" then raise Not_found;
+  let r =
+    try Some (Hashtbl.find persistent_structures name)
+    with Not_found -> None
+  in
+  match r with
+  | Some None -> raise Not_found
+  | Some (Some sg) -> sg
+  | None ->
+      let filename =
+        try find_in_path_uncap !load_path (name ^ ".cmi")
+        with Not_found ->
+          Hashtbl.add persistent_structures name None;
+          raise Not_found
+      in
+      read_pers_struct name filename
 
 let reset_cache () =
   current_unit := "";
   Hashtbl.clear persistent_structures;
-  Consistbl.clear crc_units
+  Consistbl.clear crc_units;
+  Hashtbl.clear value_declarations;
+  Hashtbl.clear type_declarations
+
+let reset_missing_cmis () =
+  let l = Hashtbl.fold (fun name r acc -> if r = None then name :: acc else acc) persistent_structures [] in
+  List.iter (Hashtbl.remove persistent_structures) l
 
 let set_unit_name name =
   current_unit := name
@@ -220,7 +317,7 @@ let rec find_module_descr path env =
   match path with
     Pident id ->
       begin try
-        let (p, desc) = Ident.find_same id env.components
+        let (p, desc) = EnvTbl.find_same id env.components
         in desc
       with Not_found ->
         if Ident.persistent id
@@ -246,7 +343,7 @@ let rec find_module_descr path env =
 let find proj1 proj2 path env =
   match path with
     Pident id ->
-      let (p, data) = Ident.find_same id (proj1 env)
+      let (p, data) = EnvTbl.find_same id (proj1 env)
       in data
   | Pdot(p, s, pos) ->
       begin match Lazy.force(find_module_descr p env) with
@@ -262,6 +359,8 @@ let find_value =
   find (fun env -> env.values) (fun sc -> sc.comp_values)
 and find_type =
   find (fun env -> env.types) (fun sc -> sc.comp_types)
+and find_constructors =
+  find (fun env -> env.constrs_by_path) (fun sc -> sc.comp_constrs_by_path)
 and find_modtype =
   find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
 and find_class =
@@ -272,12 +371,13 @@ and find_cltype =
 (* Find the manifest type associated to a type when appropriate:
    - the type should be public or should have a private row,
    - the type should have an associated manifest type. *)
-let find_type_expansion path env =
+let find_type_expansion ?level path env =
   let decl = find_type path env in
   match decl.type_manifest with
   | Some body when decl.type_private = Public
               || decl.type_kind <> Type_abstract
-              || Btype.has_constr_row body -> (decl.type_params, body)
+              || Btype.has_constr_row body ->
+                  (decl.type_params, body, may_map snd decl.type_newtype_level)
   (* The manifest type of Private abstract data types without
      private row are still considered unknown to the type system.
      Hence, this case is caught by the following clause that also handles
@@ -293,7 +393,7 @@ let find_type_expansion_opt path env =
   match decl.type_manifest with
   (* The manifest type of Private abstract data types can still get
      an approximation using their manifest type. *)
-  | Some body -> (decl.type_params, body)
+  | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
   | _ -> raise Not_found
 
 let find_modtype_expansion path env =
@@ -305,7 +405,7 @@ let find_module path env =
   match path with
     Pident id ->
       begin try
-        let (p, data) = Ident.find_same id env.modules
+        let (p, data) = EnvTbl.find_same id env.modules
         in data
       with Not_found ->
         if Ident.persistent id then
@@ -329,7 +429,7 @@ let rec lookup_module_descr lid env =
   match lid with
     Lident s ->
       begin try
-        Ident.find_name s env.components
+        EnvTbl.find_name s env.components
       with Not_found ->
         if s = !current_unit then raise Not_found;
         let ps = find_pers_struct s in
@@ -359,7 +459,7 @@ and lookup_module lid env =
   match lid with
     Lident s ->
       begin try
-        Ident.find_name s env.modules
+        EnvTbl.find_name s env.modules
       with Not_found ->
         if s = !current_unit then raise Not_found;
         let ps = find_pers_struct s in
@@ -390,7 +490,7 @@ and lookup_module lid env =
 let lookup proj1 proj2 lid env =
   match lid with
     Lident s ->
-      Ident.find_name s (proj1 env)
+      EnvTbl.find_name s (proj1 env)
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr l env in
       begin match Lazy.force desc with
@@ -406,7 +506,7 @@ let lookup proj1 proj2 lid env =
 let lookup_simple proj1 proj2 lid env =
   match lid with
     Lident s ->
-      Ident.find_name s (proj1 env)
+      EnvTbl.find_name s (proj1 env)
   | Ldot(l, s) ->
       let (p, desc) = lookup_module_descr l env in
       begin match Lazy.force desc with
@@ -419,6 +519,8 @@ let lookup_simple proj1 proj2 lid env =
   | Lapply(l1, l2) ->
       raise Not_found
 
+let has_local_constraints env = env.local_constraints
+
 let lookup_value =
   lookup (fun env -> env.values) (fun sc -> sc.comp_values)
 let lookup_annot id e =
@@ -436,6 +538,138 @@ and lookup_class =
 and lookup_cltype =
   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 
+let mark_value_used name vd =
+  try Hashtbl.find value_declarations (name, vd.val_loc) ()
+  with Not_found -> ()
+
+let mark_type_used name vd =
+  try Hashtbl.find type_declarations (name, vd.type_loc) ()
+  with Not_found -> ()
+
+let mark_constructor_used usage name vd constr =
+  try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage
+  with Not_found -> ()
+
+let mark_exception_used usage ed constr =
+  try Hashtbl.find used_constructors ("exn", ed.exn_loc, constr) usage
+  with Not_found -> ()
+
+let set_value_used_callback name vd callback =
+  let key = (name, vd.val_loc) in
+  try
+    let old = Hashtbl.find value_declarations key in
+    Hashtbl.replace value_declarations key (fun () -> old (); callback ())
+      (* this is to support cases like:
+               let x = let x = 1 in x in x
+         where the two declarations have the same location
+         (e.g. resulting from Camlp4 expansion of grammar entries) *)
+  with Not_found ->
+    Hashtbl.add value_declarations key callback
+
+let set_type_used_callback name td callback =
+  let old = try Hashtbl.find type_declarations (name, td.type_loc) with Not_found -> assert false in
+  Hashtbl.replace type_declarations (name, td.type_loc) (fun () -> callback old)
+
+let lookup_value lid env =
+  let (_, desc) as r = lookup_value lid env in
+  mark_value_used (Longident.last lid) desc;
+  r
+
+let lookup_type lid env =
+  let (_, desc) as r = lookup_type lid env in
+  mark_type_used (Longident.last lid) desc;
+  r
+
+let mark_type_path env path =
+  let decl = try find_type path env with Not_found -> assert false in
+  mark_type_used (Path.last path) decl
+
+let ty_path = function
+  | {desc=Tconstr(path, _, _)} -> path
+  | _ -> assert false
+
+let lookup_constructor lid env =
+  let desc = lookup_constructor lid env in
+  mark_type_path env (ty_path desc.cstr_res);
+  desc
+
+let mark_constructor usage env name desc =
+  match desc.cstr_tag with
+  | Cstr_exception (_, loc) ->
+      begin
+        try Hashtbl.find used_constructors ("exn", loc, name) usage
+        with Not_found -> ()
+      end
+  | _ ->
+      let ty_path = ty_path desc.cstr_res in
+      let ty_decl = try find_type ty_path env with Not_found -> assert false in
+      let ty_name = Path.last ty_path in
+      mark_constructor_used usage ty_name ty_decl name
+
+let lookup_label lid env =
+  let desc = lookup_label lid env in
+  mark_type_path env (ty_path desc.lbl_res);
+  desc
+
+let lookup_class lid env =
+  let (_, desc) as r = lookup_class lid env in
+  (* special support for Typeclass.unbound_class *)
+  if Path.name desc.cty_path = "" then ignore (lookup_type lid env)
+  else mark_type_path env desc.cty_path;
+  r
+
+let lookup_cltype lid env =
+  let (_, desc) as r = lookup_cltype lid env in
+  if Path.name desc.clty_path = "" then ignore (lookup_type lid env)
+  else mark_type_path env desc.clty_path;
+  mark_type_path env desc.clty_path;
+  r
+
+(* GADT instance tracking *)
+
+let add_gadt_instance_level lv env =
+  {env with
+   gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances}
+
+let is_Tlink = function {desc = Tlink _} -> true | _ -> false
+
+let gadt_instance_level env t =
+  let rec find_instance = function
+      [] -> None
+    | (lv, r) :: rem ->
+        if TypeSet.exists is_Tlink !r then
+          (* Should we use set_typeset ? *)
+          r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty;
+        if TypeSet.mem t !r then Some lv else find_instance rem
+  in find_instance env.gadt_instances
+
+let add_gadt_instances env lv tl =
+  let r =
+    try List.assoc lv env.gadt_instances with Not_found -> assert false in
+  (* Format.eprintf "Added";
+  List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl;
+  Format.eprintf "@."; *)
+  set_typeset r (List.fold_right TypeSet.add tl !r)
+
+(* Only use this after expand_head! *)
+let add_gadt_instance_chain env lv t =
+  let r =
+    try List.assoc lv env.gadt_instances with Not_found -> assert false in
+  let rec add_instance t =
+    let t = repr t in
+    if not (TypeSet.mem t !r) then begin
+      (* Format.eprintf "@ %a" !Btype.print_raw t; *)
+      set_typeset r (TypeSet.add t !r);
+      match t.desc with
+        Tconstr (p, _, memo) ->
+          may add_instance (find_expans Private p !memo)
+      | _ -> ()
+    end
+  in
+  (* Format.eprintf "Added chain"; *)
+  add_instance t
+  (* Format.eprintf "@." *)
+
 (* Expand manifest module type names at the top of the given module type *)
 
 let rec scrape_modtype mty env =
@@ -451,11 +685,13 @@ let rec scrape_modtype mty env =
 (* Compute constructor descriptions *)
 
 let constructors_of_type ty_path decl =
+  let handle_variants cstrs = 
+    Datarepr.constructor_descrs
+      (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+      cstrs decl.type_private
+  in
   match decl.type_kind with
-    Type_variant cstrs ->
-      Datarepr.constructor_descrs
-        (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
-        cstrs decl.type_private
+  | Type_variant cstrs -> handle_variants cstrs
   | Type_record _ | Type_abstract -> []
 
 (* Compute label descriptions *)
@@ -464,7 +700,7 @@ let labels_of_type ty_path decl =
   match decl.type_kind with
     Type_record(labels, rep) ->
       Datarepr.label_descrs
-        (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+        (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
         labels rep decl.type_private
   | Type_variant _ | Type_abstract -> []
 
@@ -514,8 +750,9 @@ let rec components_of_module env sub path mty =
     Tmty_signature sg ->
       let c =
         { comp_values = Tbl.empty; comp_annotations = Tbl.empty;
-          comp_constrs = Tbl.empty;
+          comp_constrs = Tbl.empty; 
           comp_labels = Tbl.empty; comp_types = Tbl.empty;
+          comp_constrs_by_path = Tbl.empty;
           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
           comp_components = Tbl.empty; comp_classes = Tbl.empty;
           comp_cltypes = Tbl.empty } in
@@ -540,14 +777,19 @@ let rec components_of_module env sub path mty =
             let decl' = Subst.type_declaration sub decl in
             c.comp_types <-
               Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
+           let constructors = constructors_of_type path decl' in
+           c.comp_constrs_by_path <-
+             Tbl.add (Ident.name id) 
+               (List.map snd constructors, nopos) c.comp_constrs_by_path;
             List.iter
               (fun (name, descr) ->
                 c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs)
-              (constructors_of_type path decl');
+              constructors;
+           let labels = labels_of_type path decl' in
             List.iter
               (fun (name, descr) ->
                 c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels)
-              (labels_of_type path decl');
+              (labels);
             env := store_type_infos id path decl !env
         | Tsig_exception(id, decl) ->
             let decl' = Subst.exception_declaration sub decl in
@@ -594,40 +836,86 @@ let rec components_of_module env sub path mty =
   | Tmty_ident p ->
         Structure_comps {
           comp_values = Tbl.empty; comp_annotations = Tbl.empty;
-          comp_constrs = Tbl.empty;
-          comp_labels = Tbl.empty; comp_types = Tbl.empty;
+          comp_constrs = Tbl.empty; 
+          comp_labels = Tbl.empty; 
+          comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty;
           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
           comp_components = Tbl.empty; comp_classes = Tbl.empty;
           comp_cltypes = Tbl.empty })
 
 (* Insertion of bindings by identifier + path *)
 
-and store_value id path decl env =
+and check_usage loc id warn tbl =
+  if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin
+    let name = Ident.name id in
+    let key = (name, loc) in
+    if Hashtbl.mem tbl key then ()
+    else let used = ref false in
+    Hashtbl.add tbl key (fun () -> used := true);
+    if not (name = "" || name.[0] = '_' || name.[0] = '#')
+    then
+      !add_delayed_check_forward
+        (fun () -> if not !used then Location.prerr_warning loc (warn name))
+  end;
+
+and store_value ?check id path decl env =
+  begin match check with Some f -> check_usage decl.val_loc id f value_declarations | None -> () end;
   { env with
-    values = Ident.add id (path, decl) env.values;
+    values = EnvTbl.add id (path, decl) env.values;
     summary = Env_value(env.summary, id, decl) }
 
 and store_annot id path annot env =
   if !Clflags.annotations then
     { env with
-      annotations = Ident.add id (path, annot) env.annotations }
+      annotations = EnvTbl.add id (path, annot) env.annotations }
   else env
 
 and store_type id path info env =
+  let loc = info.type_loc in
+  check_usage loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations;
+  let constructors = constructors_of_type path info in
+  let labels = labels_of_type path info in
+
+  if not env.in_signature && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_constructor ("", false, false))
+  then begin
+    let ty = Ident.name id in
+    List.iter
+      (fun (c, _) ->
+        let k = (ty, loc, c) in
+        if not (Hashtbl.mem used_constructors k) then
+          let used = constructor_usages () in
+          Hashtbl.add used_constructors k (add_constructor_usage used);
+          if not (ty = "" || ty.[0] = '_')
+          then !add_delayed_check_forward
+              (fun () ->
+                if not used.cu_positive then
+                  Location.prerr_warning loc
+                    (Warnings.Unused_constructor
+                       (c, used.cu_pattern, used.cu_privatize)
+                    )
+              )
+      )
+      constructors
+  end;
   { env with
     constrs =
       List.fold_right
         (fun (name, descr) constrs ->
-          Ident.add (Ident.create name) descr constrs)
-        (constructors_of_type path info)
+          EnvTbl.add (Ident.create name) descr constrs)
+        constructors 
         env.constrs;
+
+    constrs_by_path = 
+      EnvTbl.add id 
+        (path,List.map snd constructors) env.constrs_by_path;
     labels =
       List.fold_right
         (fun (name, descr) labels ->
-          Ident.add (Ident.create name) descr labels)
-        (labels_of_type path info)
+          EnvTbl.add (Ident.create name) descr labels)
+        labels
         env.labels;
-    types = Ident.add id (path, info) env.types;
+    types = EnvTbl.add id (path, info) env.types;
     summary = Env_type(env.summary, id, info) }
 
 and store_type_infos id path info env =
@@ -637,35 +925,55 @@ and store_type_infos id path info env =
      keep track of type abbreviations (e.g. type t = float) in the
      computation of label representations. *)
   { env with
-    types = Ident.add id (path, info) env.types;
+    types = EnvTbl.add id (path, info) env.types;
     summary = Env_type(env.summary, id, info) }
 
 and store_exception id path decl env =
+  let loc = decl.exn_loc in
+  if not env.in_signature && not loc.Location.loc_ghost &&
+    Warnings.is_active (Warnings.Unused_exception ("", false))
+  then begin
+    let ty = "exn" in
+    let c = Ident.name id in
+    let k = (ty, loc, c) in
+    if not (Hashtbl.mem used_constructors k) then begin
+      let used = constructor_usages () in
+      Hashtbl.add used_constructors k (add_constructor_usage used);
+      !add_delayed_check_forward
+        (fun () ->
+          if not used.cu_positive then
+            Location.prerr_warning loc
+              (Warnings.Unused_exception
+                 (c, used.cu_pattern)
+              )
+        )
+    end;
+  end;
   { env with
-    constrs = Ident.add id (Datarepr.exception_descr path decl) env.constrs;
+    constrs = EnvTbl.add id (Datarepr.exception_descr path decl) env.constrs;
     summary = Env_exception(env.summary, id, decl) }
 
 and store_module id path mty env =
   { env with
-    modules = Ident.add id (path, mty) env.modules;
+    modules = EnvTbl.add id (path, mty) env.modules;
     components =
-      Ident.add id (path, components_of_module env Subst.identity path mty)
+      EnvTbl.add id (path, components_of_module env Subst.identity path mty)
                    env.components;
     summary = Env_module(env.summary, id, mty) }
 
 and store_modtype id path info env =
   { env with
-    modtypes = Ident.add id (path, info) env.modtypes;
+    modtypes = EnvTbl.add id (path, info) env.modtypes;
     summary = Env_modtype(env.summary, id, info) }
 
 and store_class id path desc env =
   { env with
-    classes = Ident.add id (path, desc) env.classes;
+    classes = EnvTbl.add id (path, desc) env.classes;
     summary = Env_class(env.summary, id, desc) }
 
 and store_cltype id path desc env =
   { env with
-    cltypes = Ident.add id (path, desc) env.cltypes;
+    cltypes = EnvTbl.add id (path, desc) env.cltypes;
     summary = Env_cltype(env.summary, id, desc) }
 
 (* Compute the components of a functor application in a path. *)
@@ -690,8 +998,8 @@ let _ =
 
 (* Insertion of bindings by identifier *)
 
-let add_value id desc env =
-  store_value id (Pident id) desc env
+let add_value ?check id desc env =
+  store_value ?check id (Pident id) desc env
 
 let add_annot id annot env =
   store_annot id (Pident id) annot env
@@ -714,12 +1022,21 @@ and add_class id ty env =
 and add_cltype id ty env =
   store_cltype id (Pident id) ty env
 
+let add_local_constraint id info elv env =
+  match info with
+    {type_manifest = Some ty; type_newtype_level = Some (lv, _)} ->
+      (* elv is the expansion level, lv is the definition level *)
+      let env =
+        add_type id {info with type_newtype_level = Some (lv, elv)} env in
+      { env with local_constraints = true }
+  | _ -> assert false
+
 (* Insertion of bindings by name *)
 
 let enter store_fun name data env =
   let id = Ident.create name in (id, store_fun id (Pident id) data env)
 
-let enter_value = enter store_value
+let enter_value ?check = enter (store_value ?check)
 and enter_type = enter store_type
 and enter_exception = enter store_exception
 and enter_module = enter store_module
@@ -784,6 +1101,18 @@ let open_pers_signature name env =
   let ps = find_pers_struct name in
   open_signature (Pident(Ident.create_persistent name)) ps.ps_sig env
 
+let open_signature ?(loc = Location.none) root sg env =
+  if not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_open "") then begin
+    let used = ref false in
+    !add_delayed_check_forward
+      (fun () ->
+        if not !used then
+          Location.prerr_warning loc (Warnings.Unused_open (Path.name root))
+      );
+    EnvTbl.with_slot used (open_signature root sg) env
+  end else
+    open_signature root sg env
+
 (* Read a signature from a file *)
 
 let read_signature modname filename =
@@ -832,7 +1161,7 @@ let save_signature_with_imports sg modname filename imports =
         ps_crcs = crcs;
         ps_filename = filename;
         ps_flags = flags } in
-    Hashtbl.add persistent_structures modname ps;
+    Hashtbl.add persistent_structures modname (Some ps);
     Consistbl.set crc_units modname crc filename
   with exn ->
     close_out oc;
@@ -856,16 +1185,19 @@ open Format
 
 let report_error ppf = function
   | Not_an_interface filename -> fprintf ppf
-      "%s@ is not a compiled interface" filename
+      "%a@ is not a compiled interface" Location.print_filename filename
+  | Wrong_version_interface (filename, older_newer) -> fprintf ppf
+      "%a@ is not a compiled interface for this version of OCaml.@.\
+       It seems to be for %s version of OCaml." Location.print_filename filename older_newer
   | Corrupted_interface filename -> fprintf ppf
-      "Corrupted compiled interface@ %s" filename
+      "Corrupted compiled interface@ %a" Location.print_filename filename
   | Illegal_renaming(modname, filename) -> fprintf ppf
-      "Wrong file naming: %s@ contains the compiled interface for@ %s"
-      filename modname
+      "Wrong file naming: %a@ contains the compiled interface for@ %s"
+      Location.print_filename filename modname
   | Inconsistent_import(name, source1, source2) -> fprintf ppf
-      "@[<hov>The files %s@ and %s@ \
+      "@[<hov>The files %a@ and %a@ \
               make inconsistent assumptions@ over interface %s@]"
-      source1 source2 name
+      Location.print_filename source1 Location.print_filename source2 name
   | Need_recursive_types(import, export) ->
       fprintf ppf
         "@[<hov>Unit %s imports from %s, which uses recursive types.@ %s@]"

diff --git a/typing/env.mli b/typing/env.mli
index 8f00972a62ef4f83739dfbc1e66e424cc2d61860..599daf88e3fba07db8efa8ff05345100661580ea 100644 (file)
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -26,17 +26,26 @@ val diff: t -> t -> Ident.t list
 
 val find_value: Path.t -> t -> value_description
 val find_type: Path.t -> t -> type_declaration
+val find_constructors: Path.t -> t -> constructor_description list
 val find_module: Path.t -> t -> module_type
 val find_modtype: Path.t -> t -> modtype_declaration
 val find_class: Path.t -> t -> class_declaration
 val find_cltype: Path.t -> t -> cltype_declaration
 
-val find_type_expansion: Path.t -> t -> type_expr list * type_expr
-val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr
+val find_type_expansion:
+    ?level:int -> Path.t -> t -> type_expr list * type_expr * int option
+val find_type_expansion_opt:
+    Path.t -> t -> type_expr list * type_expr * int option
 (* Find the manifest type information associated to a type for the sake
    of the compiler's type-based optimisations. *)
 val find_modtype_expansion: Path.t -> t -> Types.module_type
 
+val has_local_constraints: t -> bool
+val add_gadt_instance_level: int -> t -> t
+val gadt_instance_level: t -> type_expr -> int option
+val add_gadt_instances: t -> int -> type_expr list -> unit
+val add_gadt_instance_chain: t -> int -> type_expr -> unit
+
 (* Lookup by long identifiers *)
 
 val lookup_value: Longident.t -> t -> Path.t * value_description
@@ -51,7 +60,7 @@ val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration
 
 (* Insertion by identifier *)
 
-val add_value: Ident.t -> value_description -> t -> t
+val add_value: ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
 val add_annot: Ident.t -> Annot.ident -> t -> t
 val add_type: Ident.t -> type_declaration -> t -> t
 val add_exception: Ident.t -> exception_declaration -> t -> t
@@ -59,6 +68,7 @@ val add_module: Ident.t -> module_type -> t -> t
 val add_modtype: Ident.t -> modtype_declaration -> t -> t
 val add_class: Ident.t -> class_declaration -> t -> t
 val add_cltype: Ident.t -> cltype_declaration -> t -> t
+val add_local_constraint: Ident.t -> type_declaration -> int -> t -> t
 
 (* Insertion of all fields of a signature. *)
 
@@ -68,12 +78,12 @@ val add_signature: signature -> t -> t
 (* Insertion of all fields of a signature, relative to the given path.
    Used to implement open. *)
 
-val open_signature: Path.t -> signature -> t -> t
+val open_signature: ?loc:Location.t -> Path.t -> signature -> t -> t
 val open_pers_signature: string -> t -> t
 
 (* Insertion by name *)
 
-val enter_value: string -> value_description -> t -> Ident.t * t
+val enter_value: ?check:(string -> Warnings.t) -> string -> value_description -> t -> Ident.t * t
 val enter_type: string -> type_declaration -> t -> Ident.t * t
 val enter_exception: string -> exception_declaration -> t -> Ident.t * t
 val enter_module: string -> module_type -> t -> Ident.t * t
@@ -83,6 +93,7 @@ val enter_cltype: string -> cltype_declaration -> t -> Ident.t * t
 
 (* Initialize the cache of in-core module interfaces. *)
 val reset_cache: unit -> unit
+val reset_missing_cmis: unit -> unit
 
 (* Remember the name of the current compilation unit. *)
 val set_unit_name: string -> unit
@@ -130,6 +141,7 @@ val summary: t -> summary
 
 type error =
     Not_an_interface of string
+  | Wrong_version_interface of string * string
   | Corrupted_interface of string
   | Illegal_renaming of string * string
   | Inconsistent_import of string * string * string
@@ -141,6 +153,22 @@ open Format
 
 val report_error: formatter -> error -> unit
 
+
+val mark_value_used: string -> value_description -> unit
+val mark_type_used: string -> type_declaration -> unit
+
+type constructor_usage = [`Positive|`Pattern|`Privatize]
+val mark_constructor_used: constructor_usage -> string -> type_declaration -> string -> unit
+val mark_constructor: constructor_usage -> t -> string -> constructor_description -> unit
+val mark_exception_used: constructor_usage -> exception_declaration -> string -> unit
+
+val in_signature: t -> t
+
+val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit
+val set_type_used_callback: string -> type_declaration -> ((unit -> unit) -> unit) -> unit
+
 (* Forward declaration to break mutual recursion with Includemod. *)
 val check_modtype_inclusion:
       (t -> module_type -> Path.t -> module_type -> unit) ref
+(* Forward declaration to break mutual recursion with Typecore. *)
+val add_delayed_check_forward: ((unit -> unit) -> unit) ref

diff --git a/typing/ident.ml b/typing/ident.ml
index c5bc09f41801f3d632de91876e9e1aedf53002cd..4196bb8338fd9ade0f91e7ed8742d22089a641c1 100644 (file)
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/ident.mli b/typing/ident.mli
index 03e2eee48d99d9ff9b9a656b65ef016eb427cbd2..e26490a9c31f3cda0a7b0e2ee1bbd53cf30d230b 100644 (file)
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index 0bb47b52ed1614af8f7b50464427dc559a851db4..8dc35115ead91d7c3c502c60e0aae072cffd1a82 100644 (file)
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
 (*                                                                     *)

diff --git a/typing/includeclass.mli b/typing/includeclass.mli
index 5596056d0fd3e3fd98982cae4ab772574bb225fa..f5bc98a032b7c6c37eeae849e06543c5591b40bc 100644 (file)
--- a/typing/includeclass.mli
+++ b/typing/includeclass.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
 (*                                                                     *)

diff --git a/typing/includecore.ml b/typing/includecore.ml
index a088319249db10e983bc8ef5821721fc974dcd9d..55113e1b07447bdf900faaa7099ea2b9f93beeb0 100644 (file)
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -61,7 +61,10 @@ let type_manifest env ty1 params1 ty2 params2 priv2 =
     Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
       let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
       Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
-      (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) &&
+      begin match row1.row_more with
+        {desc=Tvar _|Tconstr _|Tnil} -> true
+      | _ -> false
+      end &&
       let r1, r2, pairs =
         Ctype.merge_row_fields row1.row_fields row2.row_fields in
       (not row2.row_closed ||
@@ -91,7 +94,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 =
       let (fields2,rest2) = Ctype.flatten_fields fi2 in
       Ctype.equal env true (ty1::params1) (rest2::params2) &&
       let (fields1,rest1) = Ctype.flatten_fields fi1 in
-      (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) &&
+      (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
       let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
       miss2 = [] &&
       let tl1, tl2 =
@@ -163,19 +166,27 @@ let report_type_mismatch first second decl ppf =
 let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 =
   match cstrs1, cstrs2 with
     [], []           -> []
-  | [], (cstr2,_)::_ -> [Field_missing (true, cstr2)]
-  | (cstr1,_)::_, [] -> [Field_missing (false, cstr1)]
-  | (cstr1, arg1)::rem1, (cstr2, arg2)::rem2 ->
+  | [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)]
+  | (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)]
+  | (cstr1, arg1, ret1)::rem1, (cstr2, arg2,ret2)::rem2 ->
       if cstr1 <> cstr2 then [Field_names (n, cstr1, cstr2)] else
       if List.length arg1 <> List.length arg2 then [Field_arity cstr1] else
-      if Misc.for_all2
-          (fun ty1 ty2 ->
-            Ctype.equal env true (ty1::decl1.type_params)
-                                 (ty2::decl2.type_params))
-          arg1 arg2
-      then compare_variants env decl1 decl2 (n+1) rem1 rem2
-      else [Field_type cstr1]
-
+      match ret1, ret2 with
+      | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> 
+         [Field_type cstr1]
+      | Some _, None | None, Some _ ->
+         [Field_type cstr1]
+      | _ ->      
+         if Misc.for_all2
+             (fun ty1 ty2 ->
+               Ctype.equal env true (ty1::decl1.type_params)
+                 (ty2::decl2.type_params))
+             (arg1) (arg2) 
+         then 
+           compare_variants env decl1 decl2 (n+1) rem1 rem2
+         else [Field_type cstr1]
+             
+           
 let rec compare_records env decl1 decl2 n labels1 labels2 =
   match labels1, labels2 with
     [], []           -> []
@@ -189,12 +200,19 @@ let rec compare_records env decl1 decl2 n labels1 labels2 =
       then compare_records env decl1 decl2 (n+1) rem1 rem2
       else [Field_type lab1]
 
-let type_declarations env id decl1 decl2 =
+let type_declarations env name decl1 id decl2 =
   if decl1.type_arity <> decl2.type_arity then [Arity] else
   if not (private_flags decl1 decl2) then [Privacy] else
   let err = match (decl1.type_kind, decl2.type_kind) with
       (_, Type_abstract) -> []
     | (Type_variant cstrs1, Type_variant cstrs2) ->
+        let usage =
+          if decl1.type_private = Private || decl2.type_private = Public
+          then `Positive else `Privatize
+        in
+        List.iter
+          (fun (c, _, _) -> Env.mark_constructor_used usage name decl1 c)
+          cstrs1;
         compare_variants env decl1 decl2 1 cstrs1 cstrs2
     | (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
         let err = compare_records env decl1 decl2 1 labels1 labels2 in
@@ -237,13 +255,13 @@ let type_declarations env id decl1 decl2 =
 (* Inclusion between exception declarations *)
 
 let exception_declarations env ed1 ed2 =
-  Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1 ed2
+  Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) ed1.exn_args ed2.exn_args
 
 (* Inclusion between class types *)
 let encode_val (mut, ty) rem =
   begin match mut with
     Asttypes.Mutable   -> Predef.type_unit
-  | Asttypes.Immutable -> Btype.newgenty Tvar
+  | Asttypes.Immutable -> Btype.newgenvar ()
   end
   ::ty::rem
 

diff --git a/typing/includecore.mli b/typing/includecore.mli
index a2af04ba49002061584a744ea7062773c12bf6ba..17515a8e205f6b6f4643418f8c3db72a67044874 100644 (file)
--- a/typing/includecore.mli
+++ b/typing/includecore.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -36,8 +36,8 @@ type type_mismatch =
 val value_descriptions:
     Env.t -> value_description -> value_description -> module_coercion
 val type_declarations:
-    Env.t -> Ident.t ->
-    type_declaration -> type_declaration -> type_mismatch list
+    Env.t -> string ->
+    type_declaration -> Ident.t -> type_declaration -> type_mismatch list
 val exception_declarations:
     Env.t -> exception_declaration -> exception_declaration -> bool
 (*

diff --git a/typing/includemod.ml b/typing/includemod.ml
index 4b9d4ff3c22100212acb92c350ab70405a2ec5cf..bc981ddefcdafbc9751fc70d3e1483e57fd4bcdc 100644 (file)
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -19,7 +19,7 @@ open Path
 open Types
 open Typedtree
 
-type error =
+type symptom =
     Missing_field of Ident.t
   | Value_descriptions of Ident.t * value_description * value_description
   | Type_declarations of Ident.t * type_declaration
@@ -38,6 +38,10 @@ type error =
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
 
+type pos =
+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * symptom
+
 exception Error of error list
 
 (* All functions "blah env x1 x2" check that x1 is included in x2,
@@ -46,51 +50,55 @@ exception Error of error list
 
 (* Inclusion between value descriptions *)
 
-let value_descriptions env subst id vd1 vd2 =
+let value_descriptions env cxt subst id vd1 vd2 =
+  Env.mark_value_used (Ident.name id) vd1;
   let vd2 = Subst.value_description subst vd2 in
   try
     Includecore.value_descriptions env vd1 vd2
   with Includecore.Dont_match ->
-    raise(Error[Value_descriptions(id, vd1, vd2)])
+    raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
 
 (* Inclusion between type declarations *)
 
-let type_declarations env subst id decl1 decl2 =
+let type_declarations env cxt subst id decl1 decl2 =
+  Env.mark_type_used (Ident.name id) decl1;
   let decl2 = Subst.type_declaration subst decl2 in
-  let err = Includecore.type_declarations env id decl1 decl2 in
-  if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)])
+  let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in
+  if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
 
 (* Inclusion between exception declarations *)
 
-let exception_declarations env subst id decl1 decl2 =
+let exception_declarations env cxt subst id decl1 decl2 =
+  Env.mark_exception_used `Positive decl1 (Ident.name id);
   let decl2 = Subst.exception_declaration subst decl2 in
   if Includecore.exception_declarations env decl1 decl2
   then ()
-  else raise(Error[Exception_declarations(id, decl1, decl2)])
+  else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
 
 (* Inclusion between class declarations *)
 
-let class_type_declarations env subst id decl1 decl2 =
+let class_type_declarations env cxt subst id decl1 decl2 =
   let decl2 = Subst.cltype_declaration subst decl2 in
   match Includeclass.class_type_declarations env decl1 decl2 with
     []     -> ()
-  | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)])
+  | reason ->
+      raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)])
 
-let class_declarations env subst id decl1 decl2 =
+let class_declarations env cxt subst id decl1 decl2 =
   let decl2 = Subst.class_declaration subst decl2 in
   match Includeclass.class_declarations env decl1 decl2 with
     []     -> ()
-  | reason -> raise(Error[Class_declarations(id, decl1, decl2, reason)])
+  | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)])
 
 (* Expand a module type identifier when possible *)
 
 exception Dont_match
 
-let expand_module_path env path =
+let expand_module_path env cxt path =
   try
     Env.find_modtype_expansion path env
   with Not_found ->
-    raise(Error[Unbound_modtype_path path])
+    raise(Error[cxt, Unbound_modtype_path path])
 
 (* Extract name, kind and ident from a signature item *)
 
@@ -128,28 +136,29 @@ let simplify_structure_coercion cc =
    Return the restriction that transforms a value of the smaller type
    into a value of the bigger type. *)
 
-let rec modtypes env subst mty1 mty2 =
+let rec modtypes env cxt subst mty1 mty2 =
   try
-    try_modtypes env subst mty1 mty2
+    try_modtypes env cxt subst mty1 mty2
   with
     Dont_match ->
-      raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
+      raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
   | Error reasons ->
-      raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
+      raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
+                  :: reasons))
 
-and try_modtypes env subst mty1 mty2 =
+and try_modtypes env cxt subst mty1 mty2 =
   match (mty1, mty2) with
     (_, Tmty_ident p2) ->
-      try_modtypes2 env mty1 (Subst.modtype subst mty2)
+      try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
   | (Tmty_ident p1, _) ->
-      try_modtypes env subst (expand_module_path env p1) mty2
+      try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
   | (Tmty_signature sig1, Tmty_signature sig2) ->
-      signatures env subst sig1 sig2
+      signatures env cxt subst sig1 sig2
   | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
       let arg2' = Subst.modtype subst arg2 in
-      let cc_arg = modtypes env Subst.identity arg2' arg1 in
+      let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
       let cc_res =
-        modtypes (Env.add_module param1 arg2' env)
+        modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
           (Subst.add_module param2 (Pident param1) subst) res1 res2 in
       begin match (cc_arg, cc_res) with
           (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
@@ -158,22 +167,22 @@ and try_modtypes env subst mty1 mty2 =
   | (_, _) ->
       raise Dont_match
 
-and try_modtypes2 env mty1 mty2 =
+and try_modtypes2 env cxt mty1 mty2 =
   (* mty2 is an identifier *)
   match (mty1, mty2) with
     (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
       Tcoerce_none
   | (_, Tmty_ident p2) ->
-      try_modtypes env Subst.identity mty1 (expand_module_path env p2)
+      try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
   | (_, _) ->
       assert false
 
 (* Inclusion between signatures *)
 
-and signatures env subst sig1 sig2 =
+and signatures env cxt subst sig1 sig2 =
   (* Environment used to check inclusion of components *)
   let new_env =
-    Env.add_signature sig1 env in
+    Env.add_signature sig1 (Env.in_signature env) in
   (* Build a table of the components of sig1, along with their positions.
      The table is indexed by kind and name of component *)
   let rec build_component_table pos tbl = function
@@ -202,7 +211,7 @@ and signatures env subst sig1 sig2 =
   let rec pair_components subst paired unpaired = function
       [] ->
         begin match unpaired with
-            [] -> signature_components new_env subst (List.rev paired)
+            [] -> signature_components new_env cxt subst (List.rev paired)
           | _  -> raise(Error unpaired)
         end
     | item2 :: rem ->
@@ -234,7 +243,7 @@ and signatures env subst sig1 sig2 =
             ((item1, item2, pos1) :: paired) unpaired rem
         with Not_found ->
           let unpaired =
-            if report then Missing_field id2 :: unpaired else unpaired in
+            if report then (cxt, Missing_field id2) :: unpaired else unpaired in
           pair_components subst paired unpaired rem
         end in
   (* Do the pairing and checking, and return the final coercion *)
@@ -242,65 +251,67 @@ and signatures env subst sig1 sig2 =
 
 (* Inclusion between signature components *)
 
-and signature_components env subst = function
+and signature_components env cxt subst = function
     [] -> []
   | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
-      let cc = value_descriptions env subst id1 valdecl1 valdecl2 in
+      let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
       begin match valdecl2.val_kind with
-        Val_prim p -> signature_components env subst rem
-      | _ -> (pos, cc) :: signature_components env subst rem
+        Val_prim p -> signature_components env cxt subst rem
+      | _ -> (pos, cc) :: signature_components env cxt subst rem
       end
   | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
-      type_declarations env subst id1 tydecl1 tydecl2;
-      signature_components env subst rem
+      type_declarations env cxt subst id1 tydecl1 tydecl2;
+      signature_components env cxt subst rem
   | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
     :: rem ->
-      exception_declarations env subst id1 excdecl1 excdecl2;
-      (pos, Tcoerce_none) :: signature_components env subst rem
+      exception_declarations env cxt subst id1 excdecl1 excdecl2;
+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
       let cc =
-        modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
-      (pos, cc) :: signature_components env subst rem
+        modtypes env (Module id1::cxt) subst
+          (Mtype.strengthen env mty1 (Pident id1)) mty2 in
+      (pos, cc) :: signature_components env cxt subst rem
   | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
-      modtype_infos env subst id1 info1 info2;
-      signature_components env subst rem
+      modtype_infos env cxt subst id1 info1 info2;
+      signature_components env cxt subst rem
   | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
-      class_declarations env subst id1 decl1 decl2;
-      (pos, Tcoerce_none) :: signature_components env subst rem
+      class_declarations env cxt subst id1 decl1 decl2;
+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
-      class_type_declarations env subst id1 info1 info2;
-      signature_components env subst rem
+      class_type_declarations env cxt subst id1 info1 info2;
+      signature_components env cxt subst rem
   | _ ->
       assert false
 
 (* Inclusion between module type specifications *)
 
-and modtype_infos env subst id info1 info2 =
+and modtype_infos env cxt subst id info1 info2 =
   let info2 = Subst.modtype_declaration subst info2 in
+  let cxt' = Modtype id :: cxt in
   try
     match (info1, info2) with
       (Tmodtype_abstract, Tmodtype_abstract) -> ()
     | (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
     | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
-        check_modtype_equiv env mty1 mty2
+        check_modtype_equiv env cxt' mty1 mty2
     | (Tmodtype_abstract, Tmodtype_manifest mty2) ->
-        check_modtype_equiv env (Tmty_ident(Pident id)) mty2
+        check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2
   with Error reasons ->
-    raise(Error(Modtype_infos(id, info1, info2) :: reasons))
+    raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
 
-and check_modtype_equiv env mty1 mty2 =
+and check_modtype_equiv env cxt mty1 mty2 =
   match
-    (modtypes env Subst.identity mty1 mty2,
-     modtypes env Subst.identity mty2 mty1)
+    (modtypes env cxt Subst.identity mty1 mty2,
+     modtypes env cxt Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
-  | (_, _) -> raise(Error [Modtype_permutation])
+  | (_, _) -> raise(Error [cxt, Modtype_permutation])
 
 (* Simplified inclusion check between module types (for Env) *)
 
 let check_modtype_inclusion env mty1 path1 mty2 =
   try
-    ignore(modtypes env Subst.identity
+    ignore(modtypes env [] Subst.identity
                     (Mtype.strengthen env mty1 path1) mty2)
   with Error reasons ->
     raise Not_found
@@ -312,44 +323,55 @@ let _ = Env.check_modtype_inclusion := check_modtype_inclusion
 
 let compunit impl_name impl_sig intf_name intf_sig =
   try
-    signatures Env.initial Subst.identity impl_sig intf_sig
+    signatures Env.initial [] Subst.identity impl_sig intf_sig
   with Error reasons ->
-    raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
+    raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
 
-(* Hide the substitution parameter to the outside world *)
+(* Hide the context and substitution parameters to the outside world *)
 
-let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2
-let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2
+let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
+let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
 let type_declarations env id decl1 decl2 =
-  type_declarations env Subst.identity id decl1 decl2
+  type_declarations env [] Subst.identity id decl1 decl2
 
 (* Error report *)
 
 open Format
 open Printtyp
 
+let show_loc msg ppf loc =
+  let pos = loc.Location.loc_start in
+  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
+  else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
+
+let show_locs ppf (loc1, loc2) =
+  show_loc "Expected declaration" ppf loc2;
+  show_loc "Actual declaration" ppf loc1
+
 let include_err ppf = function
   | Missing_field id ->
       fprintf ppf "The field `%a' is required but not provided" ident id
   | Value_descriptions(id, d1, d2) ->
       fprintf ppf
-       "@[<hv 2>Values do not match:@ \
-        %a@;<1 -2>is not included in@ %a@]"
-       (value_description id) d1 (value_description id) d2
+        "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
+        (value_description id) d1 (value_description id) d2;
+      show_locs ppf (d1.val_loc, d2.val_loc);
   | Type_declarations(id, d1, d2, errs) ->
-      fprintf ppf "@[@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a@]"
+      fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
         "Type declarations do not match"
         (type_declaration id) d1
         "is not included in"
         (type_declaration id) d2
+        show_locs (d1.type_loc, d2.type_loc)
         (Includecore.report_type_mismatch
            "the first" "the second" "declaration") errs
   | Exception_declarations(id, d1, d2) ->
       fprintf ppf
        "@[<hv 2>Exception declarations do not match:@ \
         %a@;<1 -2>is not included in@ %a@]"
-      (exception_declaration id) d1
-      (exception_declaration id) d2
+        (exception_declaration id) d1
+        (exception_declaration id) d2;
+      show_locs ppf (d1.exn_loc, d2.exn_loc)
   | Module_types(mty1, mty2)->
       fprintf ppf
        "@[<hv 2>Modules do not match:@ \
@@ -384,9 +406,65 @@ let include_err ppf = function
   | Unbound_modtype_path path ->
       fprintf ppf "Unbound module type %a" Printtyp.path path
 
-let report_error ppf = function
-  |  [] -> ()
-  | err :: errs ->
-      let print_errs ppf errs =
-         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
-      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
+let rec context ppf = function
+    Module id :: rem ->
+      fprintf ppf "@[<2>module %a%a@]" ident id args rem
+  | Modtype id :: rem ->
+      fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
+  | Body x :: rem ->
+      fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem
+  | Arg x :: rem ->
+      fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
+  | [] ->
+      fprintf ppf "<here>"
+and context_mty ppf = function
+    (Module _ | Modtype _) :: _ as rem ->
+      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+  | cxt -> context ppf cxt
+and args ppf = function
+    Body x :: rem ->
+      fprintf ppf "(%a)%a" ident x args rem
+  | Arg x :: rem ->
+      fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
+  | cxt ->
+      fprintf ppf " :@ %a" context_mty cxt
+
+let path_of_context = function
+    Module id :: rem ->
+      let rec subm path = function
+          [] -> path
+        | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
+        | _ -> assert false
+      in subm (Pident id) rem
+  | _ -> assert false
+
+let context ppf cxt =
+  if cxt = [] then () else
+  if List.for_all (function Module _ -> true | _ -> false) cxt then
+    fprintf ppf "In module %a:@ " path (path_of_context cxt)
+  else
+    fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
+
+let include_err ppf (cxt, err) =
+  fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err
+
+let buffer = ref ""
+let is_big obj =
+  let size = !Clflags.error_size in
+  size > 0 &&
+  begin
+    if String.length !buffer < size then buffer := String.create size;
+    try ignore (Marshal.to_buffer !buffer 0 size obj []); false
+    with _ -> true
+  end
+
+let report_error ppf errs =
+  if errs = [] then () else
+  let (errs , err) = split_last errs in
+  let pe = ref true in
+  let include_err' ppf err =
+    if not (is_big err) then fprintf ppf "%a@ " include_err err
+    else if !pe then (fprintf ppf "...@ "; pe := false)
+  in
+  let print_errs ppf = List.iter (include_err' ppf) in
+  fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err

diff --git a/typing/includemod.mli b/typing/includemod.mli
index 347fd2d6505cfe2e1bd157ed31df873536ac14e0..c1c9c1f0c091279e1ad38285ff669733a7d209eb 100644 (file)
--- a/typing/includemod.mli
+++ b/typing/includemod.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,7 +24,7 @@ val compunit: string -> signature -> string -> signature -> module_coercion
 val type_declarations:
       Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
 
-type error =
+type symptom =
     Missing_field of Ident.t
   | Value_descriptions of Ident.t * value_description * value_description
   | Type_declarations of Ident.t * type_declaration
@@ -43,6 +43,10 @@ type error =
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
 
+type pos =
+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * symptom
+
 exception Error of error list
 
 val report_error: formatter -> error list -> unit

diff --git a/typing/mtype.ml b/typing/mtype.ml
index dddc65a0e9f5bdd00d8d00eeeb978c4cc150d521..5700b59e0eb4e4b3f4465c5132434656cc3327d4 100644 (file)
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -48,8 +48,9 @@ and strengthen_sig env sg p =
       sigelt :: strengthen_sig env rem p
   | Tsig_type(id, decl, rs) :: rem ->
       let newdecl =
-        match decl.type_manifest with
-          Some ty when decl.type_private = Public -> decl
+        match decl.type_manifest, decl.type_private, decl.type_kind with
+          Some _, Public, _ -> decl
+        | Some _, Private, (Type_record _ | Type_variant _) -> decl
         | _ ->
             let manif =
               Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
@@ -110,12 +111,16 @@ let nondep_supertype env mid mty =
       match item with
         Tsig_value(id, d) ->
           Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
-                          val_kind = d.val_kind}) :: rem'
+                          val_kind = d.val_kind;
+                          val_loc = d.val_loc;
+                         }) :: rem'
       | Tsig_type(id, d, rs) ->
           Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
           :: rem'
       | Tsig_exception(id, d) ->
-          Tsig_exception(id, List.map (Ctype.nondep_type env mid) d) :: rem'
+          let d = {exn_args = List.map (Ctype.nondep_type env mid) d.exn_args;
+                   exn_loc = d.exn_loc} in
+          Tsig_exception(id, d) :: rem'
       | Tsig_module(id, mty, rs) ->
           Tsig_module(id, nondep_mty env va mty, rs) :: rem'
       | Tsig_modtype(id, d) ->

diff --git a/typing/mtype.mli b/typing/mtype.mli
index b15b09ec9c9010fcf4df1647c796b6b26b0ab2b8..a24756dc083e68e711f4510651bfbb89cb9870bc 100644 (file)
--- a/typing/mtype.mli
+++ b/typing/mtype.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/oprint.ml b/typing/oprint.ml
index 6816617343278bfcc50fce8496e366212404a2af..0bfd8797cdd38b6984c3605c5b403a98939c0c5c 100644 (file)
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*                  Projet Cristal, INRIA Rocquencourt                 *)
 (*                                                                     *)
@@ -265,9 +265,9 @@ let out_type = ref print_out_type
 (* Class types *)
 
 let type_parameter ppf (ty, (co, cn)) =
-  fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
-    (*if co then if cn then "!" else "+" else if cn then "-" else "?"*)
-    ty
+  fprintf ppf "%s%s"
+    (if not cn then "+" else if not co then "-" else "")
+    (if ty = "_" then ty else "'"^ty)
 
 let print_out_class_params ppf =
   function
@@ -350,7 +350,7 @@ and print_out_sig_item ppf =
         (if vir_flag then " virtual" else "") print_out_class_params params
         name !out_class_type clt
   | Osig_exception (id, tyl) ->
-      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
+      fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None)
   | Osig_modtype (name, Omty_abstract) ->
       fprintf ppf "@[<2>module type %s@]" name
   | Osig_modtype (name, mty) ->
@@ -428,12 +428,27 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
     print_name_args
     print_out_tkind ty
     print_constraints constraints
-and print_out_constr ppf (name, tyl) =
-  match tyl with
-    [] -> fprintf ppf "%s" name
-  | _ ->
-      fprintf ppf "@[<2>%s of@ %a@]" name
-        (print_typlist print_simple_out_type " *") tyl
+and print_out_constr ppf (name, tyl,ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "%s" name
+      | _ ->
+          fprintf ppf "@[<2>%s of@ %a@]" name
+            (print_typlist print_simple_out_type " *") tyl
+      end
+  | Some ret_type ->
+      begin match tyl with
+      | [] ->
+          fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type  ret_type
+      | _ ->
+          fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+            (print_typlist print_simple_out_type " *")
+            tyl print_simple_out_type ret_type
+      end
+
+
 and print_out_label ppf (name, mut, arg) =
   fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
     !out_type arg

diff --git a/typing/oprint.mli b/typing/oprint.mli
index 7a5121ae196e86b26db78bc3e91c33cd83ad51a7..5724355b856f80e53b89ae9faf50f220398b53dd 100644 (file)
--- a/typing/oprint.mli
+++ b/typing/oprint.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*                  Projet Cristal, INRIA Rocquencourt                 *)
 (*                                                                     *)

diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 80c28ea08516be3ad822922bda2eb53c66039c58..7d95672a0cb2327db60e2f2b8a06edada4c5f9b8 100644 (file)
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*     Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -54,7 +54,7 @@ type out_type =
   | Otyp_object of (string * out_type) list * bool option
   | Otyp_record of (string * bool * out_type) list
   | Otyp_stuff of string
-  | Otyp_sum of (string * out_type list) list
+  | Otyp_sum of (string * out_type list * out_type option) list
   | Otyp_tuple of out_type list
   | Otyp_var of bool * string
   | Otyp_variant of

diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index d73f79af6a7637bf98b5e2053aea26bfb3b1ee69..99bb5afe934138390efdc06c003d109140c0821d 100644 (file)
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -51,16 +51,10 @@ let is_absent_pat p = match p.pat_desc with
 | Tpat_variant (tag, _, row) -> is_absent tag row
 | _ -> false
 
-let sort_fields args =
-  Sort.list
-    (fun (lbl1,_) (lbl2,_) -> lbl1.lbl_pos <= lbl2.lbl_pos)
-    args
-
 let records_args l1 l2 =
-  let l1 = sort_fields l1
-  and l2 = sort_fields l2 in
+  (* Invariant: fields are already sorted by Typecore.type_label_a_list *)
   let rec combine r1 r2 l1 l2 = match l1,l2 with
-  | [],[] -> r1,r2
+  | [],[] -> List.rev r1, List.rev r2
   | [],(_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
   | (_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
   | (lbl1,p1)::rem1, (lbl2,p2)::rem2 ->
@@ -159,10 +153,10 @@ open Format
 ;;
 
 let get_constr_name tag ty tenv  = match tag with
-| Cstr_exception path -> Path.name path
+| Cstr_exception (path, _) -> Path.name path
 | _ ->
   try
-    let name,_ = get_constr tag ty tenv in name
+    let name,_,_ = get_constr tag ty tenv in name
   with
   | Datarepr.Constr_not_found -> "*Unknown constructor*"
 
@@ -294,13 +288,10 @@ let record_arg p = match p.pat_desc with
 
 
 (* Raise Not_found when pos is not present in arg *)
-
-
 let get_field pos arg =
   let _,p = List.find (fun (lbl,_) -> pos = lbl.lbl_pos) arg in
   p
 
-
 let extract_fields omegas arg =
   List.map
     (fun (lbl,_) ->
@@ -309,15 +300,6 @@ let extract_fields omegas arg =
       with Not_found -> omega)
     omegas
 
-
-
-let sort_record p = match p.pat_desc with
-| Tpat_record args ->
-    make_pat
-      (Tpat_record (sort_fields args))
-      p.pat_type p.pat_env
-| _ -> p
-
 let all_record_args lbls = match lbls with
 | ({lbl_all=lbl_all},_)::_ ->
     let t =
@@ -395,23 +377,22 @@ let discr_pat q pss =
   | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p
   | (({pat_desc = Tpat_record largs} as p)::_)::pss ->
       let new_omegas =
-        List.fold_left
-          (fun r (lbl,_) ->
+        List.fold_right
+          (fun (lbl,_) r ->
             try
               let _ = get_field lbl.lbl_pos r in
               r
             with Not_found ->
               (lbl,omega)::r)
-          (record_arg acc)
-          largs in
+          largs (record_arg acc)
+      in
       acc_pat
         (make_pat (Tpat_record new_omegas) p.pat_type p.pat_env)
         pss
   | _ -> acc in
 
   match normalize_pat q with
-  | {pat_desc= (Tpat_any | Tpat_record _)} as q ->
-      sort_record (acc_pat q pss)
+  | {pat_desc= (Tpat_any | Tpat_record _)} as q -> acc_pat q pss
   | q -> q
 
 (*
@@ -615,11 +596,32 @@ let row_of_pat pat =
   not.
 *)
 
-let full_match closing env =  match env with
+let generalized_constructor x = 
+  match x with 
+    ({pat_desc = Tpat_construct(c,_);pat_env=env},_) ->
+      c.cstr_generalized
+  | _ -> assert false
+
+let clean_env env = 
+  let rec loop = 
+    function
+      | [] -> []
+      | x :: xs ->
+         if generalized_constructor x then loop xs else x :: loop xs
+  in
+  loop env
+
+let full_match ignore_generalized closing env =  match env with
 | ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ ->
     false
-| ({pat_desc = Tpat_construct(c,_)},_) :: _ ->
-    List.length env = c.cstr_consts + c.cstr_nonconsts
+| ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ -> 
+    if ignore_generalized then
+      (* remove generalized constructors; those cases will be handled separately *)
+      let env = clean_env env in 
+      List.length env = c.cstr_normal
+    else
+      List.length env = c.cstr_consts + c.cstr_nonconsts
+
 | ({pat_desc = Tpat_variant _} as p,_) :: _ ->
     let fields =
       List.map
@@ -653,6 +655,11 @@ let full_match closing env =  match env with
 | ({pat_desc = Tpat_lazy(_)},_) :: _ -> true
 | _ -> fatal_error "Parmatch.full_match"
 
+let full_match_gadt env = match env with
+  | ({pat_desc = Tpat_construct(c,_);pat_type=typ},_) :: _ -> 
+    List.length env = c.cstr_consts + c.cstr_nonconsts
+  | _ -> true
+
 let extendable_match env = match env with
 | ({pat_desc = Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) :: _ ->
     let path = get_type_path p.pat_type p.pat_env in
@@ -708,24 +715,44 @@ let rec pat_of_constrs ex_pat = function
         (pat_of_constr ex_pat cstr,
          pat_of_constrs ex_pat rem, None)}
 
+exception Not_an_adt
+
+let rec adt_path env ty =
+  match get_type_descr ty env with
+  | {type_kind=Type_variant constr_list} ->
+      begin match (Ctype.repr ty).desc with
+      | Tconstr (path,_,_) ->
+         path
+      | _ -> assert false end
+  | {type_manifest = Some _} ->
+      adt_path env (Ctype.expand_head_once env (clean_copy ty))
+  | _ -> raise Not_an_adt
+;;
+
+let rec map_filter f  = 
+  function
+      [] -> []
+    | x :: xs ->
+       match f x with
+       | None -> map_filter f xs
+       | Some y -> y :: map_filter f xs
+
 (* Sends back a pattern that complements constructor tags all_tag *)
-let complete_constrs p all_tags = match p.pat_desc with
-| Tpat_construct (c,_) ->
-    begin try
-      let not_tags = complete_tags  c.cstr_consts c.cstr_nonconsts all_tags in
-      List.map
-        (fun tag ->
-          let _,targs = get_constr tag p.pat_type p.pat_env in
-          {c with
-      cstr_tag = tag ;
-      cstr_args = targs ;
-      cstr_arity = List.length targs})
-        not_tags
-with
-| Datarepr.Constr_not_found ->
-    fatal_error "Parmatch.complete_constr: constr_not_found"
-    end
-| _ -> fatal_error "Parmatch.complete_constr"
+let complete_constrs p all_tags = 
+  match p.pat_desc with
+  | Tpat_construct (c,_) ->
+      begin try
+       let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
+       let constrs = Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in
+       map_filter
+          (fun cnstr ->
+           if List.mem cnstr.cstr_tag not_tags then Some cnstr else None)
+         constrs
+      with
+      | Datarepr.Constr_not_found ->
+         fatal_error "Parmatch.complete_constr: constr_not_found"
+      end
+  | _ -> fatal_error "Parmatch.complete_constr"
 
 
 (* Auxiliary for build_other *)
@@ -750,7 +777,7 @@ let build_other ext env =  match env with
       (Tpat_construct
          ({c with
            cstr_tag=(Cstr_exception
-            (Path.Pident (Ident.create "*exception*")))},
+            (Path.Pident (Ident.create "*exception*"), Location.none))},
           []))
       Ctype.none Env.empty
 | ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ ->
@@ -872,6 +899,20 @@ let build_other ext env =  match env with
 | [] -> omega
 | _ -> omega
 
+let build_other_gadt ext env = 
+  match env with
+    | ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ ->
+        let get_tag = function
+          | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag
+          | _ -> fatal_error "Parmatch.get_tag" in
+        let all_tags =  List.map (fun (p,_) -> get_tag p) env in
+       let cnstrs  = complete_constrs p all_tags in
+       let pats = List.map (pat_of_constr p) cnstrs in
+        (* List.iter (Format.eprintf "%a@." top_pretty) pats;
+           Format.eprintf "@.@."; *)
+        pats
+    | _ -> assert false
+         
 (*
   Core function :
   Is the last row of pattern matrix pss + qs satisfiable ?
@@ -909,7 +950,7 @@ let rec satisfiable pss qs = match pss with
           (* first column of pss is made of variables only *)
         | [] -> satisfiable (filter_extra pss) qs
         | constrs  ->
-            if full_match false constrs then
+            if full_match false false constrs then
               List.exists
                 (fun (p,pss) ->
                   not (is_absent_pat p) &&
@@ -934,13 +975,36 @@ type 'a result =
   | Rnone           (* No matching value *)
   | Rsome of 'a     (* This matching value *)
 
-let rec try_many f = function
+let rec orify_many =
+  let rec orify x y = 
+    make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env       
+  in
+  function
+    | [] -> assert false
+    | [x] -> x
+    | x :: xs -> orify x (orify_many xs)
+  
+let rec try_many  f = function
   | [] -> Rnone
-  | x::rest ->
-      begin match f x with
-      | Rnone -> try_many f rest
+  | (p,pss)::rest ->
+      match f (p,pss) with
+      | Rnone -> try_many  f rest
       | r -> r
-      end
+
+
+let rec try_many_gadt  f = function
+  | [] -> Rnone
+  | (p,pss)::rest ->
+      match f (p,pss) with
+      | Rnone -> try_many f rest
+      | Rsome sofar -> 
+         let others = try_many f rest in 
+         match others with
+           Rnone -> Rsome sofar
+         | Rsome sofar' ->
+             Rsome (sofar @ sofar')
+                 
+
 
 let rec exhaust ext pss n = match pss with
 | []    ->  Rsome (omegas n)
@@ -966,7 +1030,7 @@ let rec exhaust ext pss n = match pss with
             | Rsome r -> Rsome (set_args p r)
             | r       -> r in
         if
-          full_match false constrs && not (should_extend ext constrs)
+          full_match true false constrs && not (should_extend ext constrs)
         then
           try_many try_non_omega constrs
         else
@@ -989,6 +1053,99 @@ let rec exhaust ext pss n = match pss with
               | Empty -> fatal_error "Parmatch.exhaust"
     end
 
+let combinations f lst lst' = 
+  let rec iter2 x = 
+    function
+       [] -> []
+      | y :: ys ->
+         f x y :: iter2 x ys
+  in
+  let rec iter =
+    function
+       [] -> []
+      | x :: xs -> iter2 x lst' @ iter xs
+  in
+  iter lst
+    
+(* strictly more powerful than exhaust; however, exhaust
+   was kept for backwards compatibility *)
+let rec exhaust_gadt ext pss n = match pss with
+| []    ->  Rsome [omegas n]
+| []::_ ->  Rnone
+| pss   ->
+    let q0 = discr_pat omega pss in
+    begin match filter_all q0 pss with
+          (* first column of pss is made of variables only *)
+    | [] ->
+        begin match exhaust_gadt ext (filter_extra pss) (n-1) with
+        | Rsome r -> Rsome (List.map (fun row -> q0::row) r)
+        | r -> r
+      end
+    | constrs ->
+        let try_non_omega (p,pss) =
+          if is_absent_pat p then
+            Rnone
+          else
+            match
+              exhaust_gadt
+                ext pss (List.length (simple_match_args p omega) + n - 1)
+            with
+            | Rsome r -> Rsome (List.map (fun row ->  (set_args p row)) r)
+            | r       -> r in
+       let before = try_many_gadt try_non_omega constrs in
+        if
+         full_match_gadt constrs && not (should_extend ext constrs)
+        then
+         before
+        else
+          (*
+            D = filter_extra pss is the default matrix
+            as it is included in pss, one can avoid
+            recursive calls on specialized matrices,
+            Essentially :
+           * D exhaustive => pss exhaustive
+           * D non-exhaustive => we have a non-filtered value
+           *)
+          let r =  exhaust_gadt ext (filter_extra pss) (n-1) in
+          match r with
+          | Rnone -> before
+          | Rsome r ->
+              try
+               let missing_trailing = build_other_gadt ext constrs in
+               let before = 
+                 match before with 
+                   Rnone -> [] 
+                 | Rsome lst -> lst 
+               in
+               let dug = 
+                 combinations
+                   (fun head tail ->
+                     head :: tail)
+                   missing_trailing
+                   r
+               in
+                Rsome (dug @ before) 
+              with
+      (* cannot occur, since constructors don't make a full signature *)
+              | Empty -> fatal_error "Parmatch.exhaust"
+    end
+
+let exhaust_gadt ext pss n = 
+  let ret = exhaust_gadt ext pss n in 
+  match ret with
+    Rnone -> Rnone
+  | Rsome lst ->
+      (* The following line is needed to compile stdlib/printf.ml *)
+      if lst = [] then Rsome (omegas n) else
+      let singletons = 
+       List.map 
+         (function 
+             [x] -> x
+           | _ -> assert false)
+         lst
+      in
+      Rsome [orify_many singletons]
+
 (*
    Another exhaustiveness check, enforcing variant typing.
    Note that it does not check exact exhaustiveness, but whether a
@@ -1015,12 +1172,12 @@ let rec pressure_variants tdefs = function
                 try_non_omega rem && ok
             | [] -> true
           in
-          if full_match (tdefs=None) constrs then
+          if full_match true (tdefs=None) constrs then
             try_non_omega constrs
           else if tdefs = None then
             pressure_variants None (filter_extra pss)
           else
-            let full = full_match true constrs in
+            let full = full_match true true constrs in
             let ok =
               if full then try_non_omega constrs
               else try_non_omega (filter_all q0 (mark_partial pss))
@@ -1394,7 +1551,6 @@ with
 | Empty -> lub p2 q
 
 and record_lubs l1 l2 =
-  let l1 = sort_fields l1 and l2 = sort_fields l2 in
   let rec lub_rec l1 l2 = match l1,l2 with
   | [],_ -> l2
   | _,[] -> l1
@@ -1516,7 +1672,120 @@ let check_partial_all v casel =
 (* Exhaustiveness check *)
 (************************)
 
-let do_check_partial loc casel pss = match pss with
+
+  let rec get_first f = 
+    function
+      | [] -> None
+      | x :: xs -> 
+         match f x with 
+         | None -> get_first f xs
+         | x -> x
+
+
+(* conversion from Typedtree.pattern to Parsetree.pattern list *)
+module Conv = struct
+  open Parsetree
+  let mkpat desc = 
+    {ppat_desc = desc;
+     ppat_loc = Location.none}
+
+  let rec select : 'a list list -> 'a list list = 
+    function
+      | xs :: [] -> List.map (fun y -> [y]) xs
+      | (x::xs)::ys ->
+         List.map
+           (fun lst -> x :: lst)
+           (select ys)
+         @
+           select (xs::ys)
+      | _ -> []
+
+  let name_counter = ref 0 
+  let fresh () = 
+    let current = !name_counter in 
+    name_counter := !name_counter + 1;
+    "#$%^@*@" ^ string_of_int current
+
+  let conv (typed: Typedtree.pattern) : 
+      Parsetree.pattern list * 
+      (string,Types.constructor_description) Hashtbl.t * 
+      (string,Types.label_description) Hashtbl.t
+      = 
+    let constrs = Hashtbl.create 0 in 
+    let labels = Hashtbl.create 0 in 
+    let rec loop pat = 
+      match pat.pat_desc with
+        Tpat_or (a,b,_) ->
+         loop a @ loop b
+      | Tpat_any | Tpat_constant _ | Tpat_var _ ->
+         [mkpat Ppat_any]
+      | Tpat_alias (p,_) -> loop p
+      | Tpat_tuple lst ->
+         let results = select (List.map loop lst) in 
+         List.map
+           (fun lst -> mkpat (Ppat_tuple lst))
+           results
+      | Tpat_construct (cstr,lst) ->
+         let id = fresh () in 
+         Hashtbl.add constrs id cstr;
+         let results = select (List.map loop lst) in
+         begin match lst with
+           [] ->
+             [mkpat (Ppat_construct(Longident.Lident id, None, false))]
+          | _ ->
+             List.map 
+               (fun lst ->
+                 let arg = 
+                   match lst with
+                     [] -> assert false
+                   | [x] -> Some x
+                   | _ -> Some (mkpat (Ppat_tuple lst))
+                 in
+                 mkpat (Ppat_construct(Longident.Lident id, arg, false)))
+               results
+          end
+      | Tpat_variant(label,p_opt,row_desc) ->
+         begin match p_opt with
+         | None ->
+             [mkpat (Ppat_variant(label, None))]
+         | Some p ->
+             let results = loop p in 
+             List.map
+               (fun p ->
+                 mkpat (Ppat_variant(label, Some p)))
+               results
+          end
+      | Tpat_record subpatterns ->
+         let pats = 
+           select
+             (List.map (fun (_,x) -> (loop x)) subpatterns)
+         in
+         let label_idents = 
+           List.map 
+             (fun (lbl,_) -> 
+               let id = fresh () in 
+               Hashtbl.add labels id lbl;
+               Longident.Lident id)  
+             subpatterns
+         in 
+         List.map
+           (fun lst ->
+             let lst = List.combine label_idents lst in
+             mkpat (Ppat_record (lst, Open)))
+           pats
+      | Tpat_array lst ->
+         let results = select (List.map loop lst) in 
+         List.map (fun lst -> mkpat (Ppat_array lst)) results
+      | Tpat_lazy p ->
+         let results = loop p in 
+         List.map (fun p -> mkpat (Ppat_lazy p)) results
+    in
+    let ps = loop typed in 
+    (ps, constrs, labels)
+end
+
+
+let do_check_partial ?pred exhaust loc casel pss = match pss with
 | [] ->
         (*
           This can occur
@@ -1534,31 +1803,48 @@ let do_check_partial loc casel pss = match pss with
 | ps::_  ->
     begin match exhaust None pss (List.length ps) with
     | Rnone -> Total
-    | Rsome [v] ->
-        let errmsg =
-          try
-            let buf = Buffer.create 16 in
-            let fmt = formatter_of_buffer buf in
-            top_pretty fmt v;
-            begin match check_partial_all v casel with
-            | None -> ()
-            | Some _ ->
-                  (* This is 'Some loc', where loc is the location of
-                     a possibly matching clause.
-                     Forget about loc, because printing two locations
-                     is a pain in the top-level *)
-                Buffer.add_string buf
-                  "\n(However, some guarded clause may match this value.)"
-            end ;
-            Buffer.contents buf
-          with _ ->
-            "" in
-        Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
-        Partial
+    | Rsome [u] ->
+       let v = 
+         match pred with 
+         | Some pred ->
+             let (patterns,constrs,labels) = Conv.conv u in 
+             get_first (pred constrs labels) patterns
+         | None -> Some u
+       in
+       begin match v with
+         None -> Total
+       | Some v ->
+            let errmsg =
+              try
+               let buf = Buffer.create 16 in
+               let fmt = formatter_of_buffer buf in
+               top_pretty fmt v;
+               begin match check_partial_all v casel with
+               | None -> ()
+               | Some _ ->
+                    (* This is 'Some loc', where loc is the location of
+                       a possibly matching clause.
+                       Forget about loc, because printing two locations
+                       is a pain in the top-level *)
+                    Buffer.add_string buf
+                      "\n(However, some guarded clause may match this value.)"
+               end ;
+               Buffer.contents buf
+              with _ ->
+               "" in
+            Location.prerr_warning loc (Warnings.Partial_match errmsg) ;
+            Partial end
     | _ ->
         fatal_error "Parmatch.check_partial"
     end
 
+let do_check_partial_normal loc casel pss = 
+  do_check_partial exhaust loc casel pss
+
+let do_check_partial_gadt pred loc casel pss = 
+  do_check_partial ~pred exhaust_gadt loc casel pss
+
+
 
 (*****************)
 (* Fragile check *)
@@ -1576,6 +1862,7 @@ let extendable_path path =
   not
     (Path.same path Predef.path_bool ||
     Path.same path Predef.path_list ||
+    Path.same path Predef.path_unit ||
     Path.same path Predef.path_option)
 
 let rec collect_paths_from_pat r p = match p.pat_desc with
@@ -1607,7 +1894,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
       the type is extended.
 *)
 
-let do_check_fragile loc casel pss =
+let do_check_fragile_param exhaust loc casel pss =
   let exts =
     List.fold_left
       (fun r (p,_) -> collect_paths_from_pat r p)
@@ -1627,30 +1914,8 @@ let do_check_fragile loc casel pss =
             | Rsome _ -> ())
           exts
 
-
-(********************************)
-(* Exported exhustiveness check *)
-(********************************)
-
-(*
-   Fragile check is performed when required and
-   on exhaustive matches only.
-*)
-
-let check_partial loc casel =
-  if Warnings.is_active (Warnings.Partial_match "") then begin
-    let pss = initial_matrix casel in
-    let pss = get_mins le_pats pss in
-    let total = do_check_partial loc casel pss in
-    if
-      total = Total && Warnings.is_active (Warnings.Fragile_match "")
-    then begin
-      do_check_fragile loc casel pss
-    end ;
-    total
-  end else
-    Partial
-
+let do_check_fragile_normal = do_check_fragile_param exhaust
+let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt
 
 (********************************)
 (* Exported unused clause check *)
@@ -1677,7 +1942,7 @@ let check_unused tdefs casel =
                         p.pat_loc Warnings.Unused_pat)
                     ps
               | Used -> ()
-            with e -> assert false
+            with Empty | Not_an_adt | Not_found | NoGuard -> assert false
             end ;
 
           if has_guard act then
@@ -1715,3 +1980,47 @@ let rec inactive pat = match pat with
 (* A `fluid' pattern is both irrefutable and inactive *)
 
 let fluid pat = irrefutable pat && inactive pat.pat_desc
+
+
+
+
+
+
+           
+(********************************)
+(* Exported exhustiveness check *)
+(********************************)
+
+(*
+   Fragile check is performed when required and
+   on exhaustive matches only.
+*)
+
+let check_partial_param do_check_partial do_check_fragile loc casel = 
+    if Warnings.is_active (Warnings.Partial_match "") then begin
+      let pss = initial_matrix casel in
+      let pss = get_mins le_pats pss in
+      let total = do_check_partial loc casel pss in
+      if
+       total = Total && Warnings.is_active (Warnings.Fragile_match "")
+      then begin
+       do_check_fragile loc casel pss
+      end ;
+      total
+    end else
+      Partial  
+
+let check_partial = 
+    check_partial_param 
+      do_check_partial_normal 
+      do_check_fragile_normal
+
+let check_partial_gadt pred loc casel =
+  (*ignores GADT constructors *)
+  let first_check = check_partial loc casel in
+  match first_check with
+  | Partial -> Partial
+  | Total -> 
+      (* checks for missing GADT constructors *)
+      check_partial_param (do_check_partial_gadt pred)
+        do_check_fragile_gadt loc casel

diff --git a/typing/parmatch.mli b/typing/parmatch.mli
index 7ef6a830877ed154bced868b09297ef4c0ef582c..0cfaad7b812d8928b67219da9f18793c676bfe4c 100644 (file)
--- a/typing/parmatch.mli
+++ b/typing/parmatch.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -52,6 +52,11 @@ val complete_constrs :
 
 val pressure_variants: Env.t -> pattern list -> unit
 val check_partial: Location.t -> (pattern * expression) list -> partial
+val check_partial_gadt: 
+    ((string,constructor_description) Hashtbl.t -> 
+     (string,label_description) Hashtbl.t ->
+     Parsetree.pattern -> pattern option) -> 
+    Location.t -> (pattern * expression) list -> partial
 val check_unused: Env.t -> (pattern * expression) list -> unit
 
 (* Irrefutability tests *)

diff --git a/typing/path.ml b/typing/path.ml
index 009550261c25b370f65eb571dc892a427dc55852..7dc821a1e3344103bddc33fb8495a440ac8444e5 100644 (file)
--- a/typing/path.ml
+++ b/typing/path.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -37,12 +37,20 @@ let rec binding_time = function
   | Pdot(p, s, pos) -> binding_time p
   | Papply(p1, p2) -> max (binding_time p1) (binding_time p2)
 
-let rec name = function
+let kfalse x = false
+
+let rec name ?(paren=kfalse) = function
     Pident id -> Ident.name id
-  | Pdot(p, s, pos) -> name p ^ "." ^ s
-  | Papply(p1, p2) -> name p1 ^ "(" ^ name p2 ^ ")"
+  | Pdot(p, s, pos) ->
+      name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s
+  | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")"
 
 let rec head = function
     Pident id -> id
   | Pdot(p, s, pos) -> head p
   | Papply(p1, p2) -> assert false
+
+let rec last = function
+  | Pident id -> Ident.name id
+  | Pdot(_, s, _) -> s
+  | Papply(_, p) -> last p

diff --git a/typing/path.mli b/typing/path.mli
index 96f3e98369b8176d81d79fb1a4e8aa5582495c50..bdcc6ccabe90df49e0dde5750c64a10d55ae92ac 100644 (file)
--- a/typing/path.mli
+++ b/typing/path.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -25,5 +25,8 @@ val binding_time: t -> int
 
 val nopos: int
 
-val name: t -> string
+val name: ?paren:(string -> bool) -> t -> string
+    (* [paren] tells whether a path suffix needs parentheses *)
 val head: t -> Ident.t
+
+val last: t -> string

diff --git a/typing/predef.ml b/typing/predef.ml
index 728eb5729528551b82b950322e5e18c0a9960e33..432440b17700949fbdef85a955e4f2b304843663 100644 (file)
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -89,79 +89,98 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [];
      type_arity = 0;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = []}
+     type_variance = [];
+     type_newtype_level = None}
   and decl_bool =
     {type_params = [];
      type_arity = 0;
-     type_kind = Type_variant(["false", []; "true", []]);
+     type_kind = Type_variant(["false", [], None; "true", [], None]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = []}
+     type_variance = [];
+     type_newtype_level = None}
   and decl_unit =
     {type_params = [];
      type_arity = 0;
-     type_kind = Type_variant(["()", []]);
+     type_kind = Type_variant(["()", [], None]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = []}
+     type_variance = [];
+     type_newtype_level = None}
   and decl_exn =
     {type_params = [];
      type_arity = 0;
      type_kind = Type_variant [];
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = []}
+     type_variance = [];
+     type_newtype_level = None}
   and decl_array =
     let tvar = newgenvar() in
     {type_params = [tvar];
      type_arity = 1;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = [true, true, true]}
+     type_variance = [true, true, true];
+     type_newtype_level = None}
   and decl_list =
     let tvar = newgenvar() in
     {type_params = [tvar];
      type_arity = 1;
      type_kind =
-       Type_variant(["[]", []; "::", [tvar; type_list tvar]]);
+     Type_variant(["[]", [], None; "::", [tvar; type_list tvar], None]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = [true, false, false]}
+     type_variance = [true, false, false];
+     type_newtype_level = None}
   and decl_format6 =
     {type_params = [
-       newgenvar(); newgenvar(); newgenvar();
-       newgenvar(); newgenvar(); newgenvar();
-     ];
+     newgenvar(); newgenvar(); newgenvar();
+     newgenvar(); newgenvar(); newgenvar();
+   ];
      type_arity = 6;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = [
-       true, true, true; true, true, true;
-       true, true, true; true, true, true;
-       true, true, true; true, true, true;
-     ]}
+     true, true, true; true, true, true;
+     true, true, true; true, true, true;
+     true, true, true; true, true, true;
+   ];
+     type_newtype_level = None}
   and decl_option =
     let tvar = newgenvar() in
     {type_params = [tvar];
      type_arity = 1;
-     type_kind = Type_variant(["None", []; "Some", [tvar]]);
+     type_kind = Type_variant(["None", [], None; "Some", [tvar], None]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = [true, false, false]}
+     type_variance = [true, false, false];
+     type_newtype_level = None}
   and decl_lazy_t =
     let tvar = newgenvar() in
     {type_params = [tvar];
      type_arity = 1;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
-     type_variance = [true, false, false]}
+     type_variance = [true, false, false];
+     type_newtype_level = None}
   in
 
+  let add_exception id l = add_exception id { exn_args = l; exn_loc = Location.none } in
   add_exception ident_match_failure
                          [newgenty (Ttuple[type_string; type_int; type_int])] (
   add_exception ident_out_of_memory [] (

diff --git a/typing/predef.mli b/typing/predef.mli
index b7bbb6f4b2c58b5fdba8e1d27248c1121067102f..43e37965c8d34b4c97042caf82049bb7ab379516 100644 (file)
--- a/typing/predef.mli
+++ b/typing/predef.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/primitive.ml b/typing/primitive.ml
index 3d7ab5f7cb3b9064450b9e5f90299cd09b67b20c..a5c376596764ccc3b8b47ae6f8046dccde508181 100644 (file)
--- a/typing/primitive.ml
+++ b/typing/primitive.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/primitive.mli b/typing/primitive.mli
index 8446037f400ee712e283f581a052a2cac1986226..0b48079a825a30a7a718292c5921ff716557a9ad 100644 (file)
--- a/typing/primitive.mli
+++ b/typing/primitive.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 081e300832871f0f7db134cfa2041b217428d954..84c0d19425a1dcec3ab02c36c2703c5dfcb2973e 100644 (file)
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -109,6 +109,10 @@ let rec list_of_memo = function
   | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem
   | Mlink rem -> list_of_memo !rem
 
+let print_name ppf = function
+    None -> fprintf ppf "None"
+  | Some name -> fprintf ppf "\"%s\"" name
+
 let visited = ref []
 let rec raw_type ppf ty =
   let ty = safe_repr [] ty in
@@ -119,7 +123,7 @@ let rec raw_type ppf ty =
   end
 and raw_type_list tl = raw_list raw_type tl
 and raw_type_desc ppf = function
-    Tvar -> fprintf ppf "Tvar"
+    Tvar name -> fprintf ppf "Tvar %a" print_name name
   | Tarrow(l,t1,t2,c) ->
       fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
         l raw_type t1 raw_type t2
@@ -143,7 +147,7 @@ and raw_type_desc ppf = function
   | Tnil -> fprintf ppf "Tnil"
   | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
   | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
-  | Tunivar -> fprintf ppf "Tunivar"
+  | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
   | Tpoly (t, tl) ->
       fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
         raw_type t
@@ -183,32 +187,68 @@ let raw_type_expr ppf t =
   raw_type ppf t;
   visited := []
 
+let () = Btype.print_raw := raw_type_expr
+
 (* Print a type expression *)
 
 let names = ref ([] : (type_expr * string) list)
 let name_counter = ref 0
+let named_vars = ref ([] : string list)
+
+let reset_names () = names := []; name_counter := 0; named_vars := []
+let add_named_var ty =
+  match ty.desc with
+    Tvar (Some name) | Tunivar (Some name) ->
+      if List.mem name !named_vars then () else
+      named_vars := name :: !named_vars
+  | _ -> ()
 
-let reset_names () = names := []; name_counter := 0
-
-let new_name () =
+let rec new_name () =
   let name =
     if !name_counter < 26
     then String.make 1 (Char.chr(97 + !name_counter))
     else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
            string_of_int(!name_counter / 26) in
   incr name_counter;
-  name
+  if List.mem name !named_vars
+  || List.exists (fun (_, name') -> name = name') !names
+  then new_name ()
+  else name
 
 let name_of_type t =
+  (* We've already been through repr at this stage, so t is our representative
+     of the union-find class. *)
   try List.assq t !names with Not_found ->
-    let name = new_name () in
-    names := (t, name) :: !names;
+    let name =
+      match t.desc with
+        Tvar (Some name) | Tunivar (Some name) ->
+          (* Some part of the type we've already printed has assigned another
+           * unification variable to that name. We want to keep the name, so try
+           * adding a number until we find a name that's not taken. *)
+          let current_name = ref name in
+          let i = ref 0 in
+          while List.exists (fun (_, name') -> !current_name = name') !names do
+            current_name := name ^ (string_of_int !i);
+            i := !i + 1;
+          done;
+          !current_name
+      | _ ->
+          (* No name available, create a new one *)
+          new_name ()
+    in
+    (* Exception for type declarations *)
+    if name <> "_" then names := (t, name) :: !names;
     name
 
 let check_name_of_type t = ignore(name_of_type t)
 
+let remove_names tyl =
+  let tyl = List.map repr tyl in
+  names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
+
+
 let non_gen_mark sch ty =
-  if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
+  if sch && is_Tvar ty && ty.level <> generic_level then "_" else ""
 
 let print_name_of_type sch ppf t =
   fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t)
@@ -223,9 +263,13 @@ let add_delayed t =
 let is_aliased ty = List.memq (proxy ty) !aliased
 let add_alias ty =
   let px = proxy ty in
-  if not (is_aliased px) then aliased := px :: !aliased
+  if not (is_aliased px) then begin
+    aliased := px :: !aliased;
+    add_named_var px
+  end
+
 let aliasable ty =
-  match ty.desc with Tvar | Tunivar | Tpoly _ -> false | _ -> true
+  match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true
 
 let namable_row row =
   row.row_name <> None &&
@@ -243,7 +287,7 @@ let rec mark_loops_rec visited ty =
   if List.memq px visited && aliasable ty then add_alias px else
     let visited = px :: visited in
     match ty.desc with
-    | Tvar -> ()
+    | Tvar _ -> add_named_var ty
     | Tarrow(_, ty1, ty2, _) ->
         mark_loops_rec visited ty1; mark_loops_rec visited ty2
     | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
@@ -288,7 +332,7 @@ let rec mark_loops_rec visited ty =
     | Tpoly (ty, tyl) ->
         List.iter (fun t -> add_alias t) tyl;
         mark_loops_rec visited ty
-    | Tunivar -> ()
+    | Tunivar _ -> add_named_var ty
 
 let mark_loops ty =
   normalize_type Env.empty ty;
@@ -320,7 +364,7 @@ let rec tree_of_typexp sch ty =
 
   let pr_typ () =
     match ty.desc with
-    | Tvar ->
+    | Tvar _ ->
         Otyp_var (is_non_gen sch ty, name_of_type ty)
     | Tarrow(l, ty1, ty2, _) ->
         let pr_arrow l ty1 ty2 =
@@ -377,26 +421,35 @@ let rec tree_of_typexp sch ty =
             Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
         end
     | Tobject (fi, nm) ->
-        tree_of_typobject sch fi nm
+        tree_of_typobject sch fi !nm
+    | Tnil | Tfield _ ->
+        tree_of_typobject sch ty None
     | Tsubst ty ->
         tree_of_typexp sch ty
-    | Tlink _ | Tnil | Tfield _ ->
+    | Tlink _ ->
         fatal_error "Printtyp.tree_of_typexp"
     | Tpoly (ty, []) ->
         tree_of_typexp sch ty
     | Tpoly (ty, tyl) ->
+        (*let print_names () =
+          List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
+          prerr_string "; " in *)
         let tyl = List.map repr tyl in
-        (* let tyl = List.filter is_aliased tyl in *)
         if tyl = [] then tree_of_typexp sch ty else begin
           let old_delayed = !delayed in
+          (* Make the names delayed, so that the real type is
+             printed once when used as proxy *)
           List.iter add_delayed tyl;
           let tl = List.map name_of_type tyl in
           let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
+          (* Forget names when we leave scope *)
+          remove_names tyl;
           delayed := old_delayed; tr
         end
-    | Tunivar ->
+    | Tunivar _ ->
         Otyp_var (false, name_of_type ty)
     | Tpackage (p, n, tyl) ->
+        let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in
         Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
   in
   if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
@@ -419,7 +472,7 @@ and tree_of_typlist sch tyl =
   List.map (tree_of_typexp sch) tyl
 
 and tree_of_typobject sch fi nm =
-  begin match !nm with
+  begin match nm with
   | None ->
       let pr_fields fi =
         let (fields, rest) = flatten_fields fi in
@@ -431,7 +484,7 @@ and tree_of_typobject sch fi nm =
                | _ -> l)
             fields [] in
         let sorted_fields =
-          Sort.list (fun (n, _) (n', _) -> n <= n') present_fields in
+          List.sort (fun (n, _) (n', _) -> compare n n') present_fields in
         tree_of_typfields sch rest sorted_fields in
       let (fields, rest) = pr_fields fi in
       Otyp_object (fields, rest)
@@ -444,13 +497,13 @@ and tree_of_typobject sch fi nm =
   end
 
 and is_non_gen sch ty =
-    sch && ty.desc = Tvar && ty.level <> generic_level
+    sch && is_Tvar ty && ty.level <> generic_level
 
 and tree_of_typfields sch rest = function
   | [] ->
       let rest =
         match rest.desc with
-        | Tvar | Tunivar -> Some (is_non_gen sch rest)
+        | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
         | Tconstr _ -> Some false
         | Tnil -> None
         | _ -> fatal_error "typfields (1)"
@@ -533,9 +586,12 @@ let rec tree_of_type_decl id decl =
   in
   begin match decl.type_kind with
   | Type_abstract -> ()
-  | Type_variant [] -> ()
   | Type_variant cstrs ->
-      List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
+      List.iter 
+       (fun (_, args,ret_type_opt) -> 
+         List.iter mark_loops args;
+         may mark_loops ret_type_opt)
+       cstrs
   | Type_record(l, rep) ->
       List.iter (fun (_, _, ty) -> mark_loops ty) l
   end;
@@ -550,13 +606,16 @@ let rec tree_of_type_decl id decl =
       match decl.type_kind with
         Type_abstract ->
           decl.type_manifest = None || decl.type_private = Private
-      | Type_variant _ | Type_record _ ->
+      | Type_record _ ->
           decl.type_private = Private
+      | Type_variant tll ->
+          decl.type_private = Private ||
+          List.exists (fun (_,_,ret) -> ret <> None) tll
     in
     let vari =
       List.map2
         (fun ty (co,cn,ct) ->
-          if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true))
+          if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true))
         decl.type_params decl.type_variance
     in
     (Ident.name id,
@@ -587,8 +646,20 @@ let rec tree_of_type_decl id decl =
   in
   (name, args, ty, priv, constraints)
 
-and tree_of_constructor (name, args) =
-  (name, tree_of_typlist false args)
+and tree_of_constructor (name, args, ret_type_opt) =
+  if ret_type_opt = None then (name, tree_of_typlist false args, None) else
+  let nm = !names in
+  names := [];
+  let ret = may_map (tree_of_typexp false) ret_type_opt in
+  let args = tree_of_typlist false args in
+  names := nm;
+  (name, args, ret)
+    
+
+and tree_of_constructor_ret =
+  function
+    | None -> None
+    | Some ret_type -> Some (tree_of_typexp false ret_type)
 
 and tree_of_label (name, mut, arg) =
   (name, mut = Mutable, tree_of_typexp false arg)
@@ -602,8 +673,8 @@ let type_declaration id ppf decl =
 (* Print an exception declaration *)
 
 let tree_of_exception_declaration id decl =
-  reset_and_mark_loops_list decl;
-  let tyl = tree_of_typlist false decl in
+  reset_and_mark_loops_list decl.exn_args;
+  let tyl = tree_of_typlist false decl.exn_args in
   Osig_exception (Ident.name id, tyl)
 
 let exception_declaration id ppf decl =
@@ -632,16 +703,18 @@ let class_var sch ppf l (m, t) =
 
 let method_type (_, kind, ty) =
   match field_kind_repr kind, repr ty with
-    Fpresent, {desc=Tpoly(ty, _)} -> ty
-  | _       , ty                  -> ty
+    Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
+  | _       , ty                    -> (ty, [])
 
 let tree_of_metho sch concrete csil (lab, kind, ty) =
   if lab <> dummy_method then begin
     let kind = field_kind_repr kind in
     let priv = kind <> Fpresent in
     let virt = not (Concr.mem lab concrete) in
-    let ty = method_type (lab, kind, ty) in
-    Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil
+    let (ty, tyl) = method_type (lab, kind, ty) in
+    let tty = tree_of_typexp sch ty in
+    remove_names tyl;
+    Ocsg_method (lab, priv, virt, tty) :: csil
   end
   else csil
 
@@ -649,7 +722,7 @@ let rec prepare_class_type params = function
   | Tcty_constr (p, tyl, cty) ->
       let sty = Ctype.self_type cty in
       if List.memq (proxy sty) !visited_objects
-      || List.exists (fun ty -> (repr ty).desc <> Tvar) params
+      || not (List.for_all is_Tvar params)
       || List.exists (deep_occur sty) tyl
       then prepare_class_type params cty
       else List.iter mark_loops tyl
@@ -662,7 +735,7 @@ let rec prepare_class_type params = function
       let (fields, _) =
         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
       in
-      List.iter (fun met -> mark_loops (method_type met)) fields;
+      List.iter (fun met -> mark_loops (fst (method_type met))) fields;
       Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
   | Tcty_fun (_, ty, cty) ->
       mark_loops ty;
@@ -673,7 +746,7 @@ let rec tree_of_class_type sch params =
   | Tcty_constr (p', tyl, cty) ->
       let sty = Ctype.self_type cty in
       if List.memq (proxy sty) !visited_objects
-      || List.exists (fun ty -> (repr ty).desc <> Tvar) params
+      || not (List.for_all is_Tvar params)
       then
         tree_of_class_type sch params cty
       else
@@ -730,7 +803,7 @@ let tree_of_class_param param variance =
   (match tree_of_typexp true param with
     Otyp_var (_, s) -> s
   | _ -> "?"),
-  if (repr param).desc = Tvar then (true, true) else variance
+  if is_Tvar (repr param) then (true, true) else variance
 
 let tree_of_class_params params =
   let tyl = tree_of_typlist true params in
@@ -864,6 +937,8 @@ let rec trace fst txt ppf = function
   | _ -> ()
 
 let rec filter_trace = function
+  | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' ->
+      []
   | (t1, t1') :: (t2, t2') :: rem ->
       let rem' = filter_trace rem in
       if t1 == t1' && t2 == t2'
@@ -877,7 +952,7 @@ let hide_variant_name t =
   | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
       newty2 t.level
         (Tvariant {(row_repr row) with row_name = None;
-                   row_more = newty2 (row_more row).level Tvar})
+                   row_more = newvar2 (row_more row).level})
   | _ -> t
 
 let prepare_expansion (t, t') =
@@ -899,11 +974,10 @@ let print_tags ppf fields =
 
 let has_explanation unif t3 t4 =
   match t3.desc, t4.desc with
-    Tfield _, _ | _, Tfield _
-  | Tunivar, Tvar | Tvar, Tunivar
+    Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _
+  | _, Tvar _ | Tvar _, _
   | Tvariant _, Tvariant _ -> true
-  | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) ->
-      unif && min t3.level t4.level < Path.binding_time p
+  | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l'
   | _ -> false
 
 let rec mismatch unif = function
@@ -918,31 +992,40 @@ let rec mismatch unif = function
 
 let explanation unif t3 t4 ppf =
   match t3.desc, t4.desc with
-  | Tfield _, Tvar | Tvar, Tfield _ ->
+  | Tfield _, Tvar _ | Tvar _, Tfield _ ->
       fprintf ppf "@,Self type cannot escape its class"
-  | Tconstr (p, _, _), Tvar
+  | Tconstr (p, tl, _), Tvar _
     when unif && t4.level < Path.binding_time p ->
       fprintf ppf
         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
         path p
-  | Tvar, Tconstr (p, _, _)
+  | Tvar _, Tconstr (p, tl, _)
     when unif && t3.level < Path.binding_time p ->
       fprintf ppf
         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
         path p
-  | Tvar, Tunivar | Tunivar, Tvar ->
+  | Tvar _, Tunivar _ | Tunivar _, Tvar _ ->
       fprintf ppf "@,The universal variable %a would escape its scope"
-        type_expr (if t3.desc = Tunivar then t3 else t4)
+        type_expr (if is_Tunivar t3 then t3 else t4)
+  | Tvar _, _ | _, Tvar _ ->
+      let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in
+      if occur_in Env.empty t t' then
+        fprintf ppf "@,@[<hov>The type variable %a occurs inside@ %a@]"
+          type_expr t type_expr t'
+      else
+        fprintf ppf "@,@[<hov>This instance of %a is ambiguous:@ %s@]"
+          type_expr t'
+          "it would escape the scope of its equation"
   | Tfield (lab, _, _, _), _
   | _, Tfield (lab, _, _, _) when lab = dummy_method ->
       fprintf ppf
         "@,Self type cannot be unified with a closed object type"
-  | Tfield (l, _, _, _), Tfield (l', _, _, _) when l = l' ->
+  | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) when l = l' ->
       fprintf ppf "@,Types for method %s are incompatible" l
-  | _, Tfield (l, _, _, _) ->
+  | (Tnil|Tconstr _), Tfield (l, _, _, _) ->
       fprintf ppf
         "@,@[The first object type has no method %s@]" l
-  | Tfield (l, _, _, _), _ ->
+  | Tfield (l, _, _, _), (Tnil|Tconstr _) ->
       fprintf ppf
         "@,@[The second object type has no method %s@]" l
   | Tvariant row1, Tvariant row2 ->

diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index 5e3402ff8f174495cd2afc4a2a1ab1a60e896583..5417ebf41f44f0174ab31504228c3cbe7441bd10 100644 (file)
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/stypes.ml b/typing/stypes.ml
index 4d1166fe5bbddf8d848a44ff72bd9501d9d11b29..1d2c0efde33788a119ba140664bdf2795f984579 100644 (file)
--- a/typing/stypes.ml
+++ b/typing/stypes.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/stypes.mli b/typing/stypes.mli
index 32f92c1d712732fe1c9b8247a777431c80d2ed51..02cccd800df1f827c082dcf66c8585f2cf9d8858 100644 (file)
--- a/typing/stypes.mli
+++ b/typing/stypes.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*          Damien Doligez, projet Moscova, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/subst.ml b/typing/subst.ml
index 6aa27660611882d7644a3413ecc5c3bc531dcbe6..4a84a4e28545dc4176f4df8430d1c18e99386523 100644 (file)
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -71,18 +71,20 @@ let new_id = ref (-1)
 let reset_for_saving () = new_id := -1
 
 let newpersty desc =
-  decr new_id; { desc = desc; level = generic_level; id = !new_id }
+  decr new_id;
+  { desc = desc; level = generic_level; id = !new_id }
 
 (* Similar to [Ctype.nondep_type_rec]. *)
 let rec typexp s ty =
   let ty = repr ty in
   match ty.desc with
-    Tvar | Tunivar ->
+    Tvar _ | Tunivar _ as desc ->
       if s.for_saving || ty.id < 0 then
         let ty' =
-          if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc
+          if s.for_saving then newpersty desc
+          else newty2 ty.level desc
         in
-        save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty'
+        save_desc ty desc; ty.desc <- Tsubst ty'; ty'
       else ty
   | Tsubst ty ->
       ty
@@ -94,7 +96,7 @@ let rec typexp s ty =
     let desc = ty.desc in
     save_desc ty desc;
     (* Make a stub *)
-    let ty' = if s.for_saving then newpersty Tvar else newgenvar () in
+    let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
     ty.desc <- Tsubst ty';
     ty'.desc <-
       begin match desc with
@@ -126,11 +128,11 @@ let rec typexp s ty =
               let more' =
                 match more.desc with
                   Tsubst ty -> ty
-                | Tconstr _ -> typexp s more
-                | Tunivar | Tvar ->
+                | Tconstr _ | Tnil -> typexp s more
+                | Tunivar _ | Tvar _ ->
                     save_desc more more.desc;
                     if s.for_saving then newpersty more.desc else
-                    if dup && more.desc <> Tunivar then newgenvar () else more
+                    if dup && is_Tvar more then newgenty more.desc else more
                 | _ -> assert false
               in
               (* Register new type first for recursion *)
@@ -167,22 +169,26 @@ let type_declaration s decl =
         begin match decl.type_kind with
           Type_abstract -> Type_abstract
         | Type_variant cstrs ->
-            Type_variant(
-              List.map (fun (n, args) -> (n, List.map (typexp s) args))
-                       cstrs)
+            Type_variant
+              (List.map
+                 (fun (n, args, ret_type) -> 
+                  (n, List.map (typexp s) args, may_map (typexp s) ret_type))
+                 cstrs)
         | Type_record(lbls, rep) ->
-            Type_record(
-              List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
-                       lbls,
-              rep)
+            Type_record
+              (List.map (fun (n, mut, arg) -> (n, mut, typexp s arg)) lbls,
+               rep)
         end;
       type_manifest =
-        begin match decl.type_manifest with
-          None -> None
-        | Some ty -> Some(typexp s ty)
+        begin 
+         match decl.type_manifest with
+            None -> None
+          | Some ty -> Some(typexp s ty)
         end;
       type_private = decl.type_private;
       type_variance = decl.type_variance;
+      type_newtype_level = None;
+      type_loc = if s.for_saving then Location.none else decl.type_loc;
     }
   in
   cleanup_types ();
@@ -241,10 +247,14 @@ let class_type s cty =
 
 let value_description s descr =
   { val_type = type_expr s descr.val_type;
-    val_kind = descr.val_kind }
-
-let exception_declaration s tyl =
-  List.map (type_expr s) tyl
+    val_kind = descr.val_kind;
+    val_loc = if s.for_saving then Location.none else descr.val_loc;
+   }
+
+let exception_declaration s descr =
+  { exn_args = List.map (type_expr s) descr.exn_args;
+    exn_loc = if s.for_saving then Location.none else descr.exn_loc;
+   }
 
 let rec rename_bound_idents s idents = function
     [] -> (List.rev idents, s)

diff --git a/typing/subst.mli b/typing/subst.mli
index c861a57be3b9261970dadbd2ca3740262e31c2d8..cf977885418f72f9ec3e33e6cbf435c2f6478113 100644 (file)
--- a/typing/subst.mli
+++ b/typing/subst.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index c81e8fe8d5c11464c67d24d8a4c8aae8b62032fc..5610c3e94e0b65d2047747cf2c2b3f8798e77098 100644 (file)
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -192,21 +192,22 @@ let rc node =
 
 
 (* Enter a value in the method environment only *)
-let enter_met_env lab kind ty val_env met_env par_env =
+let enter_met_env ?check loc lab kind ty val_env met_env par_env =
   let (id, val_env) =
-    Env.enter_value lab {val_type = ty; val_kind = Val_unbound} val_env
+    Env.enter_value lab {val_type = ty; val_kind = Val_unbound; val_loc = loc} val_env
   in
   (id, val_env,
-   Env.add_value id {val_type = ty; val_kind = kind} met_env,
-   Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env)
+   Env.add_value ?check id {val_type = ty; val_kind = kind; val_loc = loc} met_env,
+   Env.add_value id {val_type = ty; val_kind = Val_unbound; val_loc = loc} par_env)
 
 (* Enter an instance variable in the environment *)
 let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
+  let instance = Ctype.instance val_env in
   let (id, virt) =
     try
       let (id, mut', virt', ty') = Vars.find lab !vars in
       if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
-      Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
+      Ctype.unify val_env (instance ty) (instance ty');
       (if not inh then Some id else None),
       (if virt' = Concrete then virt' else virt)
     with
@@ -217,7 +218,7 @@ let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc =
   let (id, _, _, _) as result =
     match id with Some id -> (id, val_env, met_env, par_env)
     | None ->
-        enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
+        enter_met_env Location.none lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env
   in
   vars := Vars.add lab (id, mut, virt, ty) !vars;
   result
@@ -461,7 +462,8 @@ let rec class_field cl_num self_type meths vars
             (val_env, met_env, par_env)
         | Some name ->
             let (id, val_env, met_env, par_env) =
-              enter_met_env name (Val_anc (inh_meths, cl_num)) self_type
+              enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s)
+                sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) self_type
                 val_env met_env par_env
             in
             (val_env, met_env, par_env)
@@ -532,7 +534,7 @@ let rec class_field cl_num self_type meths vars
                 (Typetexp.transl_simple_type val_env false sty) ty
           end;
           begin match (Ctype.repr ty).desc with
-            Tvar ->
+            Tvar _ ->
               let ty' = Ctype.newvar () in
               Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
               Ctype.unify val_env (type_approx val_env sbody) ty'
@@ -553,7 +555,7 @@ let rec class_field cl_num self_type meths vars
       let field =
         lazy begin
           let meth_type =
-            Ctype.newty (Tarrow("", self_type, Ctype.instance ty, Cok)) in
+            Btype.newgenty (Tarrow("", self_type, ty, Cok)) in
           Ctype.raise_nongen_level ();
           vars := vars_local;
           let texp = type_expect met_env meth_expr meth_type in
@@ -567,36 +569,6 @@ let rec class_field cl_num self_type meths vars
       type_constraint val_env sty sty' loc;
       (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher)
 
-  | Pcf_let (rec_flag, sdefs, loc) ->
-      let (defs, val_env) =
-        try
-          Typecore.type_let val_env rec_flag sdefs None
-        with Ctype.Unify [(ty, _)] ->
-          raise(Error(loc, Make_nongen_seltype ty))
-      in
-      let (vals, met_env, par_env) =
-        List.fold_right
-          (fun id (vals, met_env, par_env) ->
-             let expr =
-               Typecore.type_exp val_env
-                 {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
-                  pexp_loc = Location.none}
-             in
-             let desc =
-               {val_type = expr.exp_type;
-                val_kind = Val_ivar (Immutable, cl_num)}
-             in
-             let id' = Ident.create (Ident.name id) in
-             ((id', expr)
-              :: vals,
-              Env.add_value id' desc met_env,
-              Env.add_value id' desc par_env))
-          (let_bound_idents defs)
-          ([], met_env, par_env)
-      in
-      (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
-       concr_meths, warn_vals, inher)
-
   | Pcf_init expr ->
       let expr = make_method cl_num expr in
       let vars_local = !vars in
@@ -605,7 +577,8 @@ let rec class_field cl_num self_type meths vars
           Ctype.raise_nongen_level ();
           let meth_type =
             Ctype.newty
-              (Tarrow ("", self_type, Ctype.instance Predef.type_unit, Cok)) in
+              (Tarrow ("", self_type,
+                       Ctype.instance_def Predef.type_unit, Cok)) in
           vars := vars_local;
           let texp = type_expect met_env expr meth_type in
           Ctype.end_def ();
@@ -800,10 +773,16 @@ and class_expr cl_num val_env met_env scl =
       let pv =
         List.map
           (function (id, id', ty) ->
+            let path = Pident id' in
+            let vd = Env.find_value path val_env' (* do not mark the value as being used *) in
             (id,
-             Typecore.type_exp val_env'
-               {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
-                pexp_loc = Location.none}))
+             {
+              exp_desc = Texp_ident(path, vd);
+              exp_loc = Location.none;
+              exp_type = Ctype.instance val_env' vd.val_type;
+              exp_env = val_env'
+             })
+          )
           pv
       in
       let rec not_function = function
@@ -816,7 +795,8 @@ and class_expr cl_num val_env met_env scl =
            {exp_desc = Texp_constant (Asttypes.Const_int 1);
             exp_loc = Location.none;
             exp_type = Ctype.none;
-            exp_env = Env.empty }] in
+            exp_env = Env.empty }] 
+      in
       Ctype.raise_nongen_level ();
       let cl = class_expr cl_num val_env' met_env scl' in
       Ctype.end_def ();
@@ -825,7 +805,8 @@ and class_expr cl_num val_env met_env scl =
           Warnings.Unerasable_optional_argument;
       rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
           cl_loc = scl.pcl_loc;
-          cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
+          cl_type = Tcty_fun
+            (l, Ctype.instance_def pat.pat_type, cl.cl_type);
           cl_env = val_env}
   | Pcl_apply (scl', sargs) ->
       let cl = class_expr cl_num val_env met_env scl' in
@@ -861,7 +842,8 @@ and class_expr cl_num val_env met_env scl =
                 | _, (l', sarg0)::more_sargs ->
                     if l <> l' && l' <> "" then
                       raise(Error(sarg0.pexp_loc, Apply_wrong_label l'))
-                    else ([], more_sargs, Some(type_argument val_env sarg0 ty))
+                    else ([], more_sargs,
+                          Some (type_argument val_env sarg0 ty ty))
                 | _ ->
                     assert false
               end else try
@@ -877,10 +859,10 @@ and class_expr cl_num val_env met_env scl =
                 in
                 sargs, more_sargs,
                 if Btype.is_optional l' || not (Btype.is_optional l) then
-                  Some (type_argument val_env sarg0 ty)
+                  Some (type_argument val_env sarg0 ty ty)
                 else
-                  let arg = type_argument val_env
-                      sarg0 (extract_option_type val_env ty) in
+                  let ty0 = extract_option_type val_env ty in
+                  let arg = type_argument val_env sarg0 ty0 ty0 in
                   Some (option_some arg)
               with Not_found ->
                 sargs, more_sargs,
@@ -925,17 +907,24 @@ and class_expr cl_num val_env met_env scl =
       let (vals, met_env) =
         List.fold_right
           (fun id (vals, met_env) ->
+             let path = Pident id in
+             let vd = Env.find_value path val_env in (* do not mark the value as used *)
              Ctype.begin_def ();
              let expr =
-               Typecore.type_exp val_env
-                 {pexp_desc = Pexp_ident (Longident.Lident (Ident.name id));
-                  pexp_loc = Location.none}
+               {
+                exp_desc = Texp_ident(path, vd);
+                exp_loc = Location.none;
+                exp_type = Ctype.instance val_env vd.val_type;
+                exp_env = val_env;
+               }
              in
              Ctype.end_def ();
              Ctype.generalize expr.exp_type;
              let desc =
                {val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
-                                                               cl_num)}
+                                                               cl_num);
+                val_loc = vd.val_loc;
+               }
              in
              let id' = Ident.create (Ident.name id) in
              ((id', expr)
@@ -984,7 +973,7 @@ let rec approx_declaration cl =
   match cl.pcl_desc with
     Pcl_fun (l, _, _, cl) ->
       let arg =
-        if Btype.is_optional l then Ctype.instance var_option
+        if Btype.is_optional l then Ctype.instance_def var_option
         else Ctype.newvar () in
       Ctype.newty (Tarrow (l, arg, approx_declaration cl, Cok))
   | Pcl_let (_, _, cl) ->
@@ -997,14 +986,14 @@ let rec approx_description ct =
   match ct.pcty_desc with
     Pcty_fun (l, _, ct) ->
       let arg =
-        if Btype.is_optional l then Ctype.instance var_option
+        if Btype.is_optional l then Ctype.instance_def var_option
         else Ctype.newvar () in
       Ctype.newty (Tarrow (l, arg, approx_description ct, Cok))
   | _ -> Ctype.newvar ()
 
 (*******************************)
 
-let temp_abbrev env id arity =
+let temp_abbrev loc env id arity =
   let params = ref [] in
   for i = 1 to arity do
     params := Ctype.newvar () :: !params
@@ -1017,7 +1006,10 @@ let temp_abbrev env id arity =
        type_kind = Type_abstract;
        type_private = Public;
        type_manifest = Some ty;
-       type_variance = List.map (fun _ -> true, true, true) !params}
+       type_variance = List.map (fun _ -> true, true, true) !params;
+       type_newtype_level = None;
+       type_loc = loc;
+      }
       env
   in
   (!params, ty, env)
@@ -1026,8 +1018,8 @@ let rec initial_env define_class approx
     (res, env) (cl, id, ty_id, obj_id, cl_id) =
   (* Temporary abbreviations *)
   let arity = List.length (fst cl.pci_params) in
-  let (obj_params, obj_ty, env) = temp_abbrev env obj_id arity in
-  let (cl_params, cl_ty, env) = temp_abbrev env cl_id arity in
+  let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in
+  let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in
 
   (* Temporary type for the class constructor *)
   let constr_type = approx cl.pci_expr in
@@ -1103,6 +1095,7 @@ let class_infos define_class kind
   Ctype.end_def ();
 
   let sty = Ctype.self_type typ in
+  ignore (Ctype.object_fields sty);
 
   (* Generalize the row variable *)
   let rv = Ctype.row_variable sty in
@@ -1160,7 +1153,7 @@ let class_infos define_class kind
   begin try
     Ctype.unify env
       (constructor_type constr obj_type)
-      (Ctype.instance constr_type)
+      (Ctype.instance env constr_type)
   with Ctype.Unify trace ->
     raise(Error(cl.pci_loc,
                 Constructor_type_mismatch (cl.pci_name, trace)))
@@ -1220,7 +1213,7 @@ let class_infos define_class kind
      cty_new =
        match cl.pci_virt with
          Virtual  -> None
-       | Concrete -> Some (Ctype.instance constr_type)}
+       | Concrete -> Some (Ctype.instance env constr_type)}
   in
   let obj_abbr =
     {type_params = obj_params;
@@ -1228,7 +1221,9 @@ let class_infos define_class kind
      type_kind = Type_abstract;
      type_private = Public;
      type_manifest = Some obj_ty;
-     type_variance = List.map (fun _ -> true, true, true) obj_params}
+     type_variance = List.map (fun _ -> true, true, true) obj_params;
+     type_newtype_level = None;
+     type_loc = cl.pci_loc}
   in
   let (cl_params, cl_ty) =
     Ctype.instance_parameterized_type params (Ctype.self_type typ)
@@ -1241,7 +1236,9 @@ let class_infos define_class kind
      type_kind = Type_abstract;
      type_private = Public;
      type_manifest = Some cl_ty;
-     type_variance = List.map (fun _ -> true, true, true) cl_params}
+     type_variance = List.map (fun _ -> true, true, true) cl_params;
+     type_newtype_level = None;
+     type_loc = cl.pci_loc}
   in
   ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
     arity, pub_meths, List.rev !coercion_locs, expr) :: res,
@@ -1404,8 +1401,10 @@ let rec unify_parents env ty cl =
       begin try
         let decl = Env.find_class p env in
         let _, body = Ctype.find_cltype_for_path env decl.cty_path in
-        Ctype.unify env ty (Ctype.instance body)
-      with exn -> assert (exn = Not_found)
+        Ctype.unify env ty (Ctype.instance env body)
+      with
+        Not_found -> ()
+      | exn -> assert false
       end
   | Tclass_structure st -> unify_parents_struct env ty st
   | Tclass_fun (_, _, cl, _)
@@ -1603,3 +1602,4 @@ let report_error ppf = function
         "instance variable"
   | No_overriding (kind, name) ->
       fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name
+       

diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index e360ba4e172f41b3bc4b36bbc2fd85fd081b7541..9841ed40104a974ed5154a06184b04c57fcd74be 100644 (file)
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*         Jerome Vouillon, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/typing/typecore.ml b/typing/typecore.ml
index 486115488a371785e6aa0887c3c4f03781482505..a4aa5179ef3b6ec006f18a5a608bd0db7e2dcbac 100644 (file)
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -56,6 +56,11 @@ type error =
   | Not_a_variant_type of Longident.t
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Recursive_local_constraint of (type_expr * type_expr) list
+  | Unexpected_existential
 
 exception Error of Location.t * error
 
@@ -70,6 +75,10 @@ let type_module =
 let type_open =
   ref (fun _ -> assert false)
 
+(* Forward declaration, to be filled in by Typemod.type_package *)
+
+let type_package =
+  ref (fun _ -> assert false)
 
 (* Forward declaration, to be filled in by Typeclass.class_structure *)
 let type_object =
@@ -92,17 +101,116 @@ let rp node =
   node
 ;;
 
+(* Upper approximation of free identifiers on the parse tree *)
+
+let iter_expression f e =
+
+  let rec expr e =
+    f e;
+    match e.pexp_desc with
+    | Pexp_ident _
+    | Pexp_assertfalse
+    | Pexp_new _
+    | Pexp_constant _ -> ()
+    | Pexp_function (_, eo, pel) ->
+        may expr eo; List.iter (fun (_, e) -> expr e) pel
+    | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
+    | Pexp_let (_, pel, e)
+    | Pexp_match (e, pel)
+    | Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
+    | Pexp_array el
+    | Pexp_tuple el -> List.iter expr el
+    | Pexp_construct (_, eo, _)
+    | Pexp_variant (_, eo) -> may expr eo
+    | Pexp_record (iel, eo) ->
+        may expr eo; List.iter (fun (_, e) -> expr e) iel
+    | Pexp_open (_, e)
+    | Pexp_newtype (_, e)
+    | Pexp_poly (e, _)
+    | Pexp_lazy e
+    | Pexp_assert e
+    | Pexp_setinstvar (_, e)
+    | Pexp_send (e, _)
+    | Pexp_constraint (e, _, _)
+    | Pexp_field (e, _) -> expr e
+    | Pexp_when (e1, e2)
+    | Pexp_while (e1, e2)
+    | Pexp_sequence (e1, e2)
+    | Pexp_setfield (e1, _, e2) -> expr e1; expr e2
+    | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo
+    | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3
+    | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel
+    | Pexp_letmodule (_, me, e) -> expr e; module_expr me
+    | Pexp_object (_, cs) -> List.iter class_field cs
+    | Pexp_pack me -> module_expr me
+
+  and module_expr me =
+    match me.pmod_desc with
+    | Pmod_ident _ -> ()
+    | Pmod_structure str -> List.iter structure_item str
+    | Pmod_constraint (me, _)
+    | Pmod_functor (_, _, me) -> module_expr me
+    | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2
+    | Pmod_unpack e -> expr e
+
+  and structure_item str =
+    match str.pstr_desc with
+    | Pstr_eval e -> expr e
+    | Pstr_value (_, pel) -> List.iter (fun (_, e) -> expr e) pel
+    | Pstr_primitive _
+    | Pstr_type _
+    | Pstr_exception _
+    | Pstr_modtype _
+    | Pstr_open _
+    | Pstr_class_type _
+    | Pstr_exn_rebind _ -> ()
+    | Pstr_include me
+    | Pstr_module (_, me) -> module_expr me
+    | Pstr_recmodule l -> List.iter (fun (_, _, me) -> module_expr me) l
+    | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl
+
+  and class_expr ce =
+    match ce.pcl_desc with
+    | Pcl_constr _ -> ()
+    | Pcl_structure (_, cfl) -> List.iter class_field cfl
+    | Pcl_fun (_, eo, _,  ce) -> may expr eo; class_expr ce
+    | Pcl_apply (ce, lel) ->
+        class_expr ce; List.iter (fun (_, e) -> expr e) lel
+    | Pcl_let (_, pel, ce) ->
+        List.iter (fun (_, e) -> expr e) pel; class_expr ce
+    | Pcl_constraint (ce, _) -> class_expr ce
+
+  and class_field = function
+    | Pcf_inher (_, ce, _) -> class_expr ce
+    | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> ()
+    | Pcf_val (_,_,_, e, _) | Pcf_meth (_,_,_, e, _) -> expr e
+    | Pcf_init e -> expr e
+
+  in
+  expr e
+
+
+let all_idents el =
+  let idents = Hashtbl.create 8 in
+  let f = function
+    | {pexp_desc=Pexp_ident (Longident.Lident id); _} ->
+        Hashtbl.replace idents id ()
+    | _ -> ()
+  in
+  List.iter (iter_expression f) el;
+  Hashtbl.fold (fun x () rest -> x :: rest) idents []
+
 
 (* Typing of constants *)
 
 let type_constant = function
-    Const_int _ -> instance Predef.type_int
-  | Const_char _ -> instance Predef.type_char
-  | Const_string _ -> instance Predef.type_string
-  | Const_float _ -> instance Predef.type_float
-  | Const_int32 _ -> instance Predef.type_int32
-  | Const_int64 _ -> instance Predef.type_int64
-  | Const_nativeint _ -> instance Predef.type_nativeint
+    Const_int _ -> instance_def Predef.type_int
+  | Const_char _ -> instance_def Predef.type_char
+  | Const_string _ -> instance_def Predef.type_string
+  | Const_float _ -> instance_def Predef.type_float
+  | Const_int32 _ -> instance_def Predef.type_int32
+  | Const_int64 _ -> instance_def Predef.type_int64
+  | Const_nativeint _ -> instance_def Predef.type_nativeint
 
 (* Specific version of type_option, using newty rather than newgenty *)
 
@@ -125,7 +233,7 @@ let extract_option_type env ty =
   | _ -> assert false
 
 let rec extract_label_names sexp env ty =
-  let ty = repr ty in
+  let ty = expand_head env ty in
   match ty.desc with
   | Tconstr (path, _, _) ->
       let td = Env.find_type path env in
@@ -141,15 +249,55 @@ let rec extract_label_names sexp env ty =
 
 (* Typing of patterns *)
 
-(* Creating new conjunctive types is not allowed when typing patterns *)
-let unify_pat env pat expected_ty =
+(* unification inside type_pat*)
+let unify_pat_types loc env ty ty' =
   try
-    unify env pat.pat_type expected_ty
+    unify env ty ty'
   with
     Unify trace ->
-      raise(Error(pat.pat_loc, Pattern_type_clash(trace)))
+      raise(Error(loc, Pattern_type_clash(trace)))
   | Tags(l1,l2) ->
-      raise(Typetexp.Error(pat.pat_loc, Typetexp.Variant_tags (l1, l2)))
+      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+
+(* unification inside type_exp and type_expect *)
+let unify_exp_types loc env ty expected_ty =
+  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+    Printtyp.raw_type_expr expected_ty; *)
+  try
+    unify env ty expected_ty
+  with
+    Unify trace ->
+      raise(Error(loc, Expr_type_clash(trace)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+
+(* level at which to create the local type declarations *)
+let newtype_level = ref None
+let get_newtype_level () =
+  match !newtype_level with
+    Some y -> y
+  | None -> assert false
+
+let unify_pat_types_gadt loc env ty ty' =
+  let newtype_level =
+    match !newtype_level with
+    | None -> assert false
+    | Some x -> x
+  in
+  try
+    unify_gadt ~newtype_level env ty ty'
+  with
+    Unify trace ->
+      raise(Error(loc, Pattern_type_clash(trace)))
+  | Tags(l1,l2) ->
+      raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2)))
+  | Unification_recursive_abbrev trace ->
+      raise(Error(loc, Recursive_local_constraint trace))
+
+
+(* Creating new conjunctive types is not allowed when typing patterns *)
+let unify_pat env pat expected_ty =
+  unify_pat_types pat.pat_loc env pat.pat_type expected_ty
 
 (* make all Reither present in open variants *)
 let finalize_variant pat =
@@ -193,29 +341,38 @@ let has_variants p =
 
 
 (* pattern environment *)
-let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
+let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t * bool (* as-variable *)) list)
 let pattern_force = ref ([] : (unit -> unit) list)
 let pattern_scope = ref (None : Annot.ident option);;
-let reset_pattern scope =
+let allow_modules = ref false
+let module_variables = ref ([] : (string * Location.t) list)
+let reset_pattern scope allow =
   pattern_variables := [];
   pattern_force := [];
   pattern_scope := scope;
+  allow_modules := allow;
+  module_variables := [];
 ;;
 
-let enter_variable loc name ty =
-  if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
+let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty =
+  if List.exists (fun (id, _, _, _) -> Ident.name id = name) !pattern_variables
   then raise(Error(loc, Multiply_bound_variable name));
   let id = Ident.create name in
-  pattern_variables := (id, ty, loc) :: !pattern_variables;
-  begin match !pattern_scope with
-  | None -> ()
-  | Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
+  pattern_variables := (id, ty, loc, is_as_variable) :: !pattern_variables;
+  if is_module then begin
+    (* Note: unpack patterns enter a variable of the same name *)
+    if not !allow_modules then raise (Error (loc, Modules_not_allowed));
+    module_variables := (name, loc) :: !module_variables
+  end else begin
+    match !pattern_scope with
+    | None -> ()
+    | Some s -> Stypes.record (Stypes.An_ident (loc, name, s));
   end;
   id
 
 let sort_pattern_variables vs =
   List.sort
-    (fun (x,_,_) (y,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
+    (fun (x,_,_,_) (y,_,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
     vs
 
 let enter_orpat_variables loc env  p1_vs p2_vs =
@@ -225,7 +382,7 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
   and p2_vs = sort_pattern_variables p2_vs in
 
   let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
-      | (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 ->
+      | (x1,t1,l1,a1)::rem1, (x2,t2,l2,a2)::rem2 when Ident.equal x1 x2 ->
           if x1==x2 then
             unify_vars rem1 rem2
           else begin
@@ -234,13 +391,13 @@ let enter_orpat_variables loc env  p1_vs p2_vs =
             with
             | Unify trace ->
                 raise(Error(loc, Pattern_type_clash(trace)))
-            end ;
+            end;
           (x2,x1)::unify_vars rem1 rem2
           end
       | [],[] -> []
-      | (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
-      | [],(x,_,_)::_  -> raise (Error (loc, Orpat_vars x))
-      | (x,_,_)::_, (y,_,_)::_ ->
+      | (x,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
+      | [],(x,_,_,_)::_  -> raise (Error (loc, Orpat_vars x))
+      | (x,_,_,_)::_, (y,_,_,_)::_ ->
           let min_var =
             if Ident.name x < Ident.name y then x
             else y in
@@ -254,7 +411,8 @@ let rec build_as_type env p =
       let tyl = List.map (build_as_type env) pl in
       newty (Ttuple tyl)
   | Tpat_construct(cstr, pl) ->
-      if cstr.cstr_private = Private then p.pat_type else
+      let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
+      if keep then p.pat_type else
       let tyl = List.map (build_as_type env) pl in
       let ty_args, ty_res = instance_constructor cstr in
       List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty})
@@ -343,23 +501,41 @@ let build_or_pat env loc lid =
           (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some row0);
                             pat_loc=gloc; pat_env=env; pat_type=ty})
           pat pats in
-      rp { r with pat_loc = loc }
+      (rp { r with pat_loc = loc },ty)
+
+(* Records *)
 
 let rec find_record_qual = function
   | [] -> None
   | (Longident.Ldot (modname, _), _) :: _ -> Some modname
   | _ :: rest -> find_record_qual rest
 
-let type_label_a_list type_lid_a lid_a_list =
-  match find_record_qual lid_a_list with
-  | None -> List.map type_lid_a lid_a_list
-  | Some modname ->
-      List.map
-        (function
-         | (Longident.Lident id), sarg ->
-              type_lid_a (Longident.Ldot (modname, id), sarg)
-         | lid_a -> type_lid_a lid_a)
-        lid_a_list
+let type_label_a_list ?labels env loc type_lbl_a lid_a_list =
+  let record_qual = find_record_qual lid_a_list in
+  let lbl_a_list =
+    List.map
+      (fun (lid, a) ->
+        match lid, labels, record_qual with
+          Longident.Lident s, Some labels, _ when Hashtbl.mem labels s ->
+            Hashtbl.find labels s, a
+        | Longident.Lident s, _, Some modname ->
+            Typetexp.find_label env loc (Longident.Ldot (modname, s)), a
+        | _ ->
+            Typetexp.find_label env loc lid, a)
+      lid_a_list in
+  (* Invariant: records are sorted in the typed tree *)
+  let lbl_a_list =
+    List.sort
+      (fun (lbl1,_) (lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos)
+      lbl_a_list
+  in
+  List.map type_lbl_a lbl_a_list
+
+let lid_of_label label =
+  match repr label.lbl_res with
+  | {desc = Tconstr(Path.Pdot(mpath,_,_),_,_)} ->
+      Longident.Ldot(lid_of_path mpath, label.lbl_name)
+  | _ -> Longident.Lident label.lbl_name
 
 (* Checks over the labels mentioned in a record pattern:
    no duplicate definitions (error); properly closed (warning) *)
@@ -389,70 +565,114 @@ let check_recordpat_labels loc lbl_pat_list closed =
         end
       end
 
+(* unification of a type with a tconstr with
+   freshly created arguments *)
+let unify_head_only loc env ty constr =
+  let (_, ty_res) = instance_constructor constr in
+  match (repr ty_res).desc with
+  | Tconstr(p,args,m) ->
+      ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m);
+      enforce_constraints env ty_res;
+      unify_pat_types loc env ty ty_res
+  | _ -> assert false
+
 (* Typing of patterns *)
 
-let rec type_pat env sp =
+(* type_pat does not generate local constraints inside or patterns *)
+type type_pat_mode =
+  | Normal
+  | Inside_or
+
+(* type_pat propagates the expected type as well as maps for
+   constructors and labels.
+   Unification may update the typing environment. *)
+let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
+  let type_pat ?(mode=mode) ?(env=env) =
+    type_pat ~constrs ~labels ~no_existentials ~mode ~env in
   let loc = sp.ppat_loc in
   match sp.ppat_desc with
     Ppat_any ->
       rp {
         pat_desc = Tpat_any;
         pat_loc = loc;
-        pat_type = newvar();
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_var name ->
-      let ty = newvar() in
-      let id = enter_variable loc name ty in
+      let id = enter_variable loc name expected_ty in
+      rp {
+        pat_desc = Tpat_var id;
+        pat_loc = loc;
+        pat_type = expected_ty;
+        pat_env = !env }
+  | Ppat_unpack name ->
+      let id = enter_variable loc name expected_ty ~is_module:true in
       rp {
         pat_desc = Tpat_var id;
         pat_loc = loc;
-        pat_type = ty;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=loc},
                     ({ptyp_desc=Ptyp_poly _} as sty)) ->
       (* explicitly polymorphic type *)
-      let ty, force = Typetexp.transl_simple_type_delayed env sty in
+      let ty, force = Typetexp.transl_simple_type_delayed !env sty in
+      unify_pat_types loc !env ty expected_ty;
       pattern_force := force :: !pattern_force;
       begin match ty.desc with
       | Tpoly (body, tyl) ->
           begin_def ();
-          let _, ty' = instance_poly false tyl body in
+          let _, ty' = instance_poly ~keep_names:true false tyl body in
           end_def ();
           generalize ty';
           let id = enter_variable loc name ty' in
           rp { pat_desc = Tpat_var id;
                pat_loc = loc;
                pat_type = ty;
-               pat_env = env }
+               pat_env = !env }
       | _ -> assert false
       end
   | Ppat_alias(sq, name) ->
-      let q = type_pat env sq in
+      let q = type_pat sq expected_ty in
       begin_def ();
-      let ty_var = build_as_type env q in
+      let ty_var = build_as_type !env q in
       end_def ();
       generalize ty_var;
-      let id = enter_variable loc name ty_var in
+      let id = enter_variable ~is_as_variable:true loc name ty_var in
       rp {
         pat_desc = Tpat_alias(q, id);
         pat_loc = loc;
         pat_type = q.pat_type;
-        pat_env = env }
+        pat_env = !env }
   | Ppat_constant cst ->
+      unify_pat_types loc !env (type_constant cst) expected_ty;
       rp {
         pat_desc = Tpat_constant cst;
         pat_loc = loc;
-        pat_type = type_constant cst;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_tuple spl ->
-      let pl = List.map (type_pat env) spl in
+      let spl_ann = List.map (fun p -> (p,newvar ())) spl in
+      let ty = newty (Ttuple(List.map snd spl_ann)) in
+      unify_pat_types loc !env ty expected_ty;
+      let pl = List.map (fun (p,t) -> type_pat p t) spl_ann in
       rp {
         pat_desc = Tpat_tuple pl;
         pat_loc = loc;
-        pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_construct(lid, sarg, explicit_arity) ->
-      let constr = Typetexp.find_constructor env loc lid in
+      let constr =
+        match lid, constrs with
+          Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
+            Hashtbl.find constrs s
+        | _ ->  Typetexp.find_constructor !env loc lid
+      in
+      Env.mark_constructor `Pattern !env (Longident.last lid) constr;
+      if no_existentials && constr.cstr_existentials <> [] then
+        raise (Error (loc, Unexpected_existential));
+      (* if constructor is gadt, we must verify that the expected type has the
+         correct head *)
+      if constr.cstr_generalized then
+        unify_head_only loc !env expected_ty constr;
       let sargs =
         match sarg with
           None -> []
@@ -467,16 +687,21 @@ let rec type_pat env sp =
       if List.length sargs <> constr.cstr_arity then
         raise(Error(loc, Constructor_arity_mismatch(lid,
                                      constr.cstr_arity, List.length sargs)));
-      let args = List.map (type_pat env) sargs in
-      let (ty_args, ty_res) = instance_constructor constr in
-      List.iter2 (unify_pat env) args ty_args;
+      let (ty_args, ty_res) =
+        instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
+      in
+      if constr.cstr_generalized && mode = Normal then
+        unify_pat_types_gadt loc env ty_res expected_ty
+      else
+        unify_pat_types loc !env ty_res expected_ty;
+      let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in
       rp {
         pat_desc = Tpat_construct(constr, args);
         pat_loc = loc;
-        pat_type = ty_res;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_variant(l, sarg) ->
-      let arg = may_map (type_pat env) sarg in
+      let arg = may_map (fun p -> type_pat p (newvar())) sarg in
       let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type]  in
       let row = { row_fields =
                     [l, Reither(arg = None, arg_type, true, ref None)];
@@ -485,112 +710,182 @@ let rec type_pat env sp =
                   row_more = newvar ();
                   row_fixed = false;
                   row_name = None } in
+      unify_pat_types loc !env (newty (Tvariant row)) expected_ty;
       rp {
         pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()});
         pat_loc = loc;
-        pat_type = newty (Tvariant row);
-        pat_env = env }
+        pat_type =  expected_ty;
+        pat_env = !env }
   | Ppat_record(lid_sp_list, closed) ->
-      let ty = newvar() in
-      let type_label_pat (lid, sarg) =
-        let label = Typetexp.find_label env loc lid in
+      let type_label_pat (label, sarg) =
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
         if vars = [] then end_def ();
         begin try
-          unify env ty_res ty
+          unify_pat_types loc !env ty_res expected_ty
         with Unify trace ->
-          raise(Error(loc, Label_mismatch(lid, trace)))
+          raise(Error(loc, Label_mismatch(lid_of_label label, trace)))
         end;
-        let arg = type_pat env sarg in
-        unify_pat env arg ty_arg;
+        let arg = type_pat sarg ty_arg in
         if vars <> [] then begin
           end_def ();
           generalize ty_arg;
           List.iter generalize vars;
           let instantiated tv =
-            let tv = expand_head env tv in
-            tv.desc <> Tvar || tv.level <> generic_level in
+            let tv = expand_head !env tv in
+            not (is_Tvar tv) || tv.level <> generic_level in
           if List.exists instantiated vars then
-            raise (Error(loc, Polymorphic_label lid))
+            raise (Error(loc, Polymorphic_label (lid_of_label label)))
         end;
         (label, arg)
       in
-      let lbl_pat_list = type_label_a_list type_label_pat lid_sp_list in
+      let lbl_pat_list =
+        type_label_a_list ?labels !env loc type_label_pat lid_sp_list in
       check_recordpat_labels loc lbl_pat_list closed;
       rp {
         pat_desc = Tpat_record lbl_pat_list;
         pat_loc = loc;
-        pat_type = ty;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_array spl ->
-      let pl = List.map (type_pat env) spl in
       let ty_elt = newvar() in
-      List.iter (fun p -> unify_pat env p ty_elt) pl;
+      unify_pat_types
+        loc !env (instance_def (Predef.type_array ty_elt)) expected_ty;
+      let spl_ann = List.map (fun p -> (p,newvar())) spl in
+      let pl = List.map (fun (p,t) -> type_pat p ty_elt) spl_ann in
       rp {
         pat_desc = Tpat_array pl;
         pat_loc = loc;
-        pat_type = instance (Predef.type_array ty_elt);
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_or(sp1, sp2) ->
       let initial_pattern_variables = !pattern_variables in
-      let p1 = type_pat env sp1 in
+      let p1 = type_pat ~mode:Inside_or sp1 expected_ty in
       let p1_variables = !pattern_variables in
-      pattern_variables := initial_pattern_variables ;
-      let p2 = type_pat env sp2 in
+      pattern_variables := initial_pattern_variables;
+      let p2 = type_pat ~mode:Inside_or sp2 expected_ty in
       let p2_variables = !pattern_variables in
-      unify_pat env p2 p1.pat_type;
       let alpha_env =
-        enter_orpat_variables loc env p1_variables p2_variables in
-      pattern_variables := p1_variables ;
+        enter_orpat_variables loc !env p1_variables p2_variables in
+      pattern_variables := p1_variables;
       rp {
         pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
         pat_loc = loc;
-        pat_type = p1.pat_type;
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_lazy sp1 ->
-      let p1 = type_pat env sp1 in
+      let nv = newvar () in
+      unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) expected_ty;
+      let p1 = type_pat sp1 nv in
       rp {
         pat_desc = Tpat_lazy p1;
         pat_loc = loc;
-        pat_type = instance (Predef.type_lazy_t p1.pat_type);
-        pat_env = env }
+        pat_type = expected_ty;
+        pat_env = !env }
   | Ppat_constraint(sp, sty) ->
-      let p = type_pat env sp in
-      let ty, force = Typetexp.transl_simple_type_delayed env sty in
-      unify_pat env p ty;
+      (* Separate when not already separated by !principal *)
+      let separate = true in
+      if separate then begin_def();
+      let ty, force = Typetexp.transl_simple_type_delayed !env sty in
+      let ty, expected_ty' =
+        if separate then begin
+          end_def();
+          generalize_structure ty;
+          instance !env ty, instance !env ty
+        end else ty, ty
+      in
+      unify_pat_types loc !env ty expected_ty;
+      let p = type_pat sp expected_ty' in
+      (*Format.printf "%a@.%a@."
+        Printtyp.raw_type_expr ty
+        Printtyp.raw_type_expr p.pat_type;*)
       pattern_force := force :: !pattern_force;
-      p
+      if separate then
+        match p.pat_desc with
+          Tpat_var id ->
+            {p with pat_type = ty;
+             pat_desc = Tpat_alias ({p with pat_desc = Tpat_any}, id)}
+        | _ -> {p with pat_type = ty}
+      else p
   | Ppat_type lid ->
-      build_or_pat env loc lid
+      let (r,ty) = build_or_pat !env loc lid in
+      unify_pat_types loc !env ty expected_ty;
+      r
 
-let get_ref r =
-  let v = !r in r := []; v
+let type_pat ?(allow_existentials=false) ?constrs ?labels
+    ?(lev=get_current_level()) env sp expected_ty =
+  newtype_level := Some lev;
+  try
+    let r =
+      type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
+        ~mode:Normal ~env sp expected_ty in
+    iter_pattern (fun p -> p.pat_env <- !env) r;
+    newtype_level := None;
+    r
+  with e ->
+    newtype_level := None;
+    raise e
+
+
+(* this function is passed to Partial.parmatch
+   to type check gadt nonexhaustiveness *)
+let partial_pred ~lev env expected_ty constrs labels p =
+  let snap = snapshot () in
+  try
+    reset_pattern None true;
+    let typed_p =
+      type_pat ~allow_existentials:true ~lev
+        ~constrs ~labels (ref env) p expected_ty
+    in
+    backtrack snap;
+    (* types are invalidated but we don't need them here *)
+    Some typed_p
+  with _ ->
+    backtrack snap;
+    None
+
+let rec iter3 f lst1 lst2 lst3 =
+  match lst1,lst2,lst3 with
+  | x1::xs1,x2::xs2,x3::xs3 ->
+      f x1 x2 x3;
+      iter3 f xs1 xs2 xs3
+  | [],[],[] ->
+      ()
+  | _ ->
+      assert false
 
-let add_pattern_variables env =
+let add_pattern_variables ?check ?check_as env =
   let pv = get_ref pattern_variables in
-  List.fold_right
-    (fun (id, ty, loc) env ->
-       let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in
-       Env.add_annot id (Annot.Iref_internal loc) e1;
-    )
-    pv env
-
-let type_pattern env spat scope =
-  reset_pattern scope;
-  let pat = type_pat env spat in
-  let new_env = add_pattern_variables env in
-  (pat, new_env, get_ref pattern_force)
-
-let type_pattern_list env spatl scope =
-  reset_pattern scope;
-  let patl = List.map (type_pat env) spatl in
-  let new_env = add_pattern_variables env in
-  (patl, new_env, get_ref pattern_force)
+  (List.fold_right
+    (fun (id, ty, loc, as_var) env ->
+       let check = if as_var then check_as else check in
+       let e1 = Env.add_value ?check id
+           {val_type = ty; val_kind = Val_reg; val_loc = loc} env in
+       Env.add_annot id (Annot.Iref_internal loc) e1)
+    pv env,
+   get_ref module_variables)
+
+let type_pattern ~lev env spat scope expected_ty =
+  reset_pattern scope true;
+  let new_env = ref env in
+  let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in
+  let new_env, unpacks =
+    add_pattern_variables !new_env
+      ~check:(fun s -> Warnings.Unused_var_strict s)
+      ~check_as:(fun s -> Warnings.Unused_var s) in
+  (pat, new_env, get_ref pattern_force, unpacks)
+
+let type_pattern_list env spatl scope expected_tys allow =
+  reset_pattern scope allow;
+  let new_env = ref env in
+  let patl = List.map2 (type_pat new_env) spatl expected_tys in
+  let new_env, unpacks = add_pattern_variables !new_env in
+  (patl, new_env, get_ref pattern_force, unpacks)
 
 let type_class_arg_pattern cl_num val_env met_env l spat =
-  reset_pattern None;
-  let pat = type_pat val_env spat in
+  reset_pattern None false;
+  let nv = newvar () in
+  let pat = type_pat (ref val_env) spat nv in
   if has_variants pat then begin
     Parmatch.pressure_variants val_env [pat];
     iter_pattern finalize_variant pat
@@ -599,15 +894,20 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
   if is_optional l then unify_pat val_env pat (type_option (newvar ()));
   let (pv, met_env) =
     List.fold_right
-      (fun (id, ty, _loc) (pv, env) ->
+      (fun (id, ty, loc, as_var) (pv, env) ->
+         let check s =
+           if as_var then Warnings.Unused_var s
+           else Warnings.Unused_var_strict s in
          let id' = Ident.create (Ident.name id) in
          ((id', id, ty)::pv,
           Env.add_value id' {val_type = ty;
-                             val_kind = Val_ivar (Immutable, cl_num)}
+                             val_kind = Val_ivar (Immutable, cl_num);
+                             val_loc = loc;
+                            } ~check
             env))
       !pattern_variables ([], met_env)
   in
-  let val_env = add_pattern_variables val_env in
+  let val_env, _ = add_pattern_variables val_env in
   (pat, pv, val_env, met_env)
 
 let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
@@ -617,8 +917,9 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
     mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
                        "selfpat-" ^ cl_num))
   in
-  reset_pattern None;
-  let pat = type_pat val_env spat in
+  reset_pattern None false;
+  let nv = newvar() in
+  let pat = type_pat (ref val_env) spat nv in
   List.iter (fun f -> f()) (get_ref pattern_force);
   let meths = ref Meths.empty in
   let vars = ref Vars.empty in
@@ -626,12 +927,21 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
   pattern_variables := [];
   let (val_env, met_env, par_env) =
     List.fold_right
-      (fun (id, ty, _loc) (val_env, met_env, par_env) ->
-         (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
+      (fun (id, ty, loc, as_var) (val_env, met_env, par_env) ->
+         (Env.add_value id {val_type = ty;
+                            val_kind = Val_unbound;
+                            val_loc = loc;
+                           } val_env,
           Env.add_value id {val_type = ty;
-                            val_kind = Val_self (meths, vars, cl_num, privty)}
+                            val_kind = Val_self (meths, vars, cl_num, privty);
+                            val_loc = loc;
+                           }
+            ~check:(fun s -> if as_var then Warnings.Unused_var s
+                             else Warnings.Unused_var_strict s)
             met_env,
-          Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env))
+          Env.add_value id {val_type = ty; val_kind = Val_unbound;
+                            val_loc = loc;
+                           } par_env))
       pv (val_env, met_env, par_env)
   in
   (pat, meths, vars, val_env, met_env, par_env)
@@ -685,7 +995,7 @@ let rec is_nonexpansive exp =
             Cf_meth _ -> true
           | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e
           | Cf_init e -> is_nonexpansive e
-          | Cf_inher _ | Cf_let _ -> false)
+          | Cf_inher _ -> false)
         fields &&
       Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable)
         vars true &&
@@ -720,7 +1030,11 @@ and is_nonexpansive_opt = function
     None -> true
   | Some e -> is_nonexpansive e
 
-(* Typing of printf formats.
+(* Typing format strings for printing or reading.
+
+   These format strings are used by functions in modules Printf, Format, and
+   Scanf.
+
    (Handling of * modifiers contributed by Thorsten Ohl.) *)
 
 external string_to_format :
@@ -730,32 +1044,13 @@ external format_to_string :
 
 let type_format loc fmt =
 
-  let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
+  let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in
 
   let bad_conversion fmt i c =
     raise (Error (loc, Bad_conversion (fmt, i, c))) in
   let incomplete_format fmt =
     raise (Error (loc, Incomplete_format fmt)) in
 
-  let range_closing_index fmt i =
-
-    let len = String.length fmt in
-    let find_closing j =
-      if j >= len then incomplete_format fmt else
-      try String.index_from fmt j ']' with
-      | Not_found -> incomplete_format fmt in
-    let skip_pos j =
-      if j >= len then incomplete_format fmt else
-      match fmt.[j] with
-      | ']' -> find_closing (j + 1)
-      | c -> find_closing j in
-    let rec skip_neg j =
-      if j >= len then incomplete_format fmt else
-      match fmt.[j] with
-      | '^' -> skip_pos (j + 1)
-      | c -> skip_pos j in
-    find_closing (skip_neg (i + 1)) in
-
   let rec type_in_format fmt =
 
     let len = String.length fmt in
@@ -805,6 +1100,48 @@ let type_format loc fmt =
         match fmt.[j] with
         | '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
         | _ -> scan_conversion i j
+      and scan_indication j =
+        if j >= len then j - 1 else
+        match fmt.[j] with
+        | '@' ->
+          let k = j + 1 in
+          if k >= len then j - 1 else
+          begin match fmt.[k] with
+          | '%' ->
+            let k = k + 1 in
+            if k >= len then j - 1 else
+            begin match fmt.[k] with
+            | '%' | '@' -> k
+            | _c -> j - 1
+            end
+          | _c -> k
+          end
+        | _c -> j - 1
+      and scan_range j =
+        let rec scan_closing j =
+          if j >= len then incomplete_format fmt else
+          match fmt.[j] with
+          | ']' -> j
+          | '%' ->
+            let j = j + 1 in
+            if j >= len then incomplete_format fmt else
+            begin match fmt.[j] with
+            | '%' | '@' -> scan_closing (j + 1)
+            | c -> bad_conversion fmt j c
+            end
+          | c -> scan_closing (j + 1) in
+        let scan_first_pos j =
+          if j >= len then incomplete_format fmt else
+          match fmt.[j] with
+          | ']' -> scan_closing (j + 1)
+          | c -> scan_closing j in
+        let rec scan_first_neg j =
+          if j >= len then incomplete_format fmt else
+          match fmt.[j] with
+          | '^' -> scan_first_pos (j + 1)
+          | c -> scan_first_pos j in
+
+        scan_first_neg j
 
       and conversion j ty_arg =
         let ty_uresult, ty_result = scan_format (j + 1) in
@@ -824,13 +1161,16 @@ let type_format loc fmt =
       and scan_conversion i j =
         if j >= len then incomplete_format fmt else
         match fmt.[j] with
-        | '%' | '!' | ',' -> scan_format (j + 1)
-        | 's' | 'S' -> conversion j Predef.type_string
+        | '%' | '@' | '!' | ',' -> scan_format (j + 1)
+        | 's' | 'S' ->
+          let j = scan_indication (j + 1) in
+          conversion j Predef.type_string
         | '[' ->
-          let j = range_closing_index fmt j in
+          let j = scan_range (j + 1) in
+          let j = scan_indication (j + 1) in
           conversion j Predef.type_string
         | 'c' | 'C' -> conversion j Predef.type_char
-        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
+        | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' ->
           conversion j Predef.type_int
         | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
         | 'B' | 'b' -> conversion j Predef.type_bool
@@ -859,7 +1199,7 @@ let type_format loc fmt =
           let j = j + 1 in
           if j >= len then conversion (j - 1) Predef.type_int else begin
             match fmt.[j] with
-            | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+            | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
               let ty_arg =
                 match c with
                 | 'l' -> Predef.type_int32
@@ -888,9 +1228,10 @@ let type_format loc fmt =
     let ty_ureader, ty_args = scan_format 0 in
     newty
       (Tconstr
-         (Predef.path_format6,
-          [ty_args; ty_input; ty_aresult; ty_ureader; ty_uresult; ty_result],
-          ref Mnil)) in
+        (Predef.path_format6,
+         [ ty_args; ty_input; ty_aresult;
+           ty_ureader; ty_uresult; ty_result; ],
+         ref Mnil)) in
 
   type_in_format fmt
 
@@ -950,7 +1291,7 @@ let rec list_labels_aux env visited ls ty_fun =
     Tarrow (l, _, ty_res, _) ->
       list_labels_aux env (ty::visited) (l::ls) ty_res
   | _ ->
-      List.rev ls, ty.desc = Tvar
+      List.rev ls, is_Tvar ty
 
 let list_labels env ty = list_labels_aux env [] [] ty
 
@@ -966,9 +1307,10 @@ let check_univars env expans kind exp ty_expected vars =
       (fun t ->
         let t = repr t in
         generalize t;
-        if t.desc = Tvar && t.level = generic_level then
-          (log_type t; t.desc <- Tunivar; true)
-        else false)
+        match t.desc with
+          Tvar name when t.level = generic_level ->
+            log_type t; t.desc <- Tunivar name; true
+        | _ -> false)
       vars in
   if List.length vars = List.length vars' then () else
   let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
@@ -982,7 +1324,7 @@ let check_application_result env statement exp =
   match (expand_head env exp.exp_type).desc with
   | Tarrow _ ->
       Location.prerr_warning exp.exp_loc Warnings.Partial_application
-  | Tvar -> ()
+  | Tvar _ -> ()
   | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
   | _ ->
       if statement then
@@ -1007,42 +1349,111 @@ let create_package_type loc env (p, l) =
   let s = !Typetexp.transl_modtype_longident loc env p in
   newty (Tpackage (s,
                    List.map fst l,
-                   List.map (Typetexp.transl_simple_type env false) (List.map snd l)))
+                   List.map (Typetexp.transl_simple_type env false)
+                     (List.map snd l)))
+
+let wrap_unpacks sexp unpacks =
+  List.fold_left
+    (fun sexp (name, loc) ->
+      {pexp_loc = sexp.pexp_loc; pexp_desc = Pexp_letmodule (
+       name,
+       {pmod_loc = loc; pmod_desc = Pmod_unpack
+          {pexp_desc=Pexp_ident(Longident.Lident name); pexp_loc=loc}},
+       sexp)})
+    sexp unpacks
+
+(* Helpers for type_cases *)
+let iter_ppat f p = 
+  match p.ppat_desc with
+  | Ppat_any | Ppat_var _ | Ppat_constant _ 
+  | Ppat_type _ | Ppat_unpack _ -> ()    
+  | Ppat_array pats -> List.iter f pats
+  | Ppat_or (p1,p2) -> f p1; f p2
+  | Ppat_variant (_, arg) | Ppat_construct (_, arg, _) -> may f arg
+  | Ppat_tuple lst ->  List.iter f lst
+  | Ppat_alias (p,_) | Ppat_constraint (p,_) | Ppat_lazy p -> f p
+  | Ppat_record (args, flag) -> List.iter (fun (_,p) -> f p) args
+
+let contains_polymorphic_variant p =
+  let rec loop p =
+    match p.ppat_desc with
+      Ppat_variant _ | Ppat_type _ -> raise Exit
+    | _ -> iter_ppat loop p
+  in
+  try loop p; false with Exit -> true
+
+let contains_gadt env p =
+  let rec loop p =
+    match p.ppat_desc with
+      Ppat_construct (lid, _, _) ->
+        begin try
+          if (Env.lookup_constructor lid env).cstr_generalized then raise Exit
+        with Not_found -> ()
+        end; iter_ppat loop p
+    | _ -> iter_ppat loop p
+  in
+  try loop p; false with Exit -> true
+
+let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
+
+(* Duplicate types of values in the environment *)
+(* XXX Should we do something about global type variables too? *)
+
+let duplicate_ident_types loc caselist env =
+  let caselist =
+    List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
+  let idents = all_idents (List.map snd caselist) in
+  List.fold_left
+    (fun env s ->
+      try
+        (* XXX This will mark the value as being used;
+           I don't think this is what we want *)
+        let (path, desc) = Env.lookup_value (Longident.Lident s) env in
+        match path with
+          Path.Pident id ->
+            let desc = {desc with val_type = correct_levels desc.val_type} in
+            Env.add_value id desc env
+        | _ -> env
+      with Not_found -> env)
+    env idents
 
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
   (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
     Printtyp.raw_type_expr expected_ty; *)
-  try
-    unify env exp.exp_type expected_ty
-  with
-    Unify trace ->
-      raise(Error(exp.exp_loc, Expr_type_clash(trace)))
-  | Tags(l1,l2) ->
-      raise(Typetexp.Error(exp.exp_loc, Typetexp.Variant_tags (l1, l2)))
+    unify_exp_types exp.exp_loc env exp.exp_type expected_ty
 
 let rec type_exp env sexp =
+  (* We now delegate everything to type_expect *)
+  type_expect env sexp (newvar ())
+
+(* Typing of an expression with an expected type.
+   This provide better error messages, and allows controlled
+   propagation of return type information.
+   In the principal case, [type_expected'] may be at generic_level.
+ *)
+
+and type_expect ?in_function env sexp ty_expected =
   let loc = sexp.pexp_loc in
+  (* Record the expression type before unifying it with the expected type *)
+  let rue exp =
+    Stypes.record (Stypes.Ti_expr exp);
+    unify_exp env exp (instance env ty_expected);
+    exp
+  in
   match sexp.pexp_desc with
   | Pexp_ident lid ->
       begin
         if !Clflags.annotations then begin
           try let (path, annot) = Env.lookup_annot lid env in
-              let rec name_of_path = function
-                | Path.Pident id -> Ident.name id
-                | Path.Pdot(p, s, pos) ->
-                    if Oprint.parenthesized_ident s then
-                      name_of_path p ^ ".( " ^ s ^ " )"
-                    else
-                      name_of_path p ^ "." ^ s
-                | Path.Papply(p1, p2) -> name_of_path p1 ^ "(" ^ name_of_path p2 ^ ")" in
               Stypes.record
-                (Stypes.An_ident (loc, name_of_path path, annot))
+                (Stypes.An_ident (
+                 loc, Path.name ~paren:Oprint.parenthesized_ident path, annot))
           with _ -> ()
         end;
         let (path, desc) = Typetexp.find_value env loc lid in
-        re {
+        rue {
           exp_desc =
             begin match desc.val_kind with
               Val_ivar (_, cl_num) ->
@@ -1061,15 +1472,31 @@ let rec type_exp env sexp =
                 Texp_ident(path, desc)
             end;
           exp_loc = loc;
-          exp_type = instance desc.val_type;
+          exp_type = instance env desc.val_type;
           exp_env = env }
       end
+  | Pexp_constant(Const_string s as cst) ->
+      rue {
+        exp_desc = Texp_constant cst;
+        exp_loc = loc;
+        exp_type =
+        (* Terrible hack for format strings *)
+           begin match (repr (expand_head env ty_expected)).desc with
+             Tconstr(path, _, _) when Path.same path Predef.path_format6 ->
+               type_format loc s
+           | _ -> instance_def Predef.type_string
+           end;
+        exp_env = env }
   | Pexp_constant cst ->
-      re {
+      rue {
         exp_desc = Texp_constant cst;
         exp_loc = loc;
         exp_type = type_constant cst;
         exp_env = env }
+  | Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
+      type_expect ?in_function env
+        {sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
+        ty_expected
   | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
       let scp =
         match rec_flag with
@@ -1077,15 +1504,102 @@ let rec type_exp env sexp =
         | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
         | Default -> None
       in
-      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in
-      let body = type_exp new_env sbody in
+      let (pat_exp_list, new_env, unpacks) =
+        type_let env rec_flag spat_sexp_list scp true in
+      let body =
+        type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
         exp_loc = loc;
         exp_type = body.exp_type;
         exp_env = env }
-  | Pexp_function _ ->     (* defined in type_expect *)
-      type_expect env sexp (newvar())
+  | Pexp_function (l, Some default, [spat, sbody]) ->
+      let default_loc = default.pexp_loc in
+      let scases = [
+         {ppat_loc = default_loc;
+          ppat_desc =
+            Ppat_construct
+              (Longident.(Ldot (Lident "*predef*", "Some")),
+               Some {ppat_loc = default_loc; ppat_desc = Ppat_var "*sth*"},
+               false)},
+         {pexp_loc = default_loc;
+          pexp_desc = Pexp_ident(Longident.Lident "*sth*")};
+         {ppat_loc = default_loc;
+          ppat_desc = Ppat_construct
+            (Longident.(Ldot (Lident "*predef*", "None")), None, false)},
+         default;
+      ] in
+      let smatch = {
+        pexp_loc = loc;
+        pexp_desc =
+          Pexp_match ({
+            pexp_loc = loc;
+            pexp_desc = Pexp_ident(Longident.Lident "*opt*")
+            },
+            scases
+          )
+      } in
+      let sfun = {
+        pexp_loc = loc;
+        pexp_desc =
+         Pexp_function (
+           l, None,
+           [ {ppat_loc = loc;
+              ppat_desc = Ppat_var "*opt*"},
+             {pexp_loc = loc;
+              pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
+             }
+           ]
+         )
+      } in
+      type_expect ?in_function env sfun ty_expected
+  | Pexp_function (l, _, caselist) ->
+      let (loc_fun, ty_fun) =
+        match in_function with Some p -> p
+        | None -> (loc, instance env ty_expected)
+      in
+      let separate = !Clflags.principal || Env.has_local_constraints env in
+      if separate then begin_def ();
+      let (ty_arg, ty_res) =
+        try filter_arrow env (instance env ty_expected) l
+        with Unify _ ->
+          match expand_head env ty_expected with
+            {desc = Tarrow _} as ty ->
+              raise(Error(loc, Abstract_wrong_label(l, ty)))
+          | _ ->
+              raise(Error(loc_fun,
+                          Too_many_arguments (in_function <> None, ty_fun)))
+      in
+      let ty_arg =
+        if is_optional l then
+          let tv = newvar() in
+          begin
+            try unify env ty_arg (type_option tv)
+            with Unify _ -> assert false
+          end;
+          type_option tv
+        else ty_arg
+      in
+      if separate then begin
+        end_def ();
+        generalize_structure ty_arg;
+        generalize_structure ty_res
+      end;
+      let cases, partial =
+        type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
+          true loc caselist in
+      let not_function ty =
+        let ls, tvar = list_labels env ty in
+        ls = [] && not tvar
+      in
+      if is_optional l && not_function ty_res then
+        Location.prerr_warning (fst (List.hd cases)).pat_loc
+          Warnings.Unerasable_optional_argument;
+      re {
+        exp_desc = Texp_function(cases, partial);
+        exp_loc = loc;
+        exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok)));
+        exp_env = env }
   | Pexp_apply(sfunct, sargs) ->
       begin_def (); (* one more level for non-returning functions *)
       if !Clflags.principal then begin_def ();
@@ -1099,69 +1613,96 @@ let rec type_exp env sexp =
         if List.memq ty seen then () else
         match ty.desc with
           Tarrow (l, ty_arg, ty_fun, com) ->
-            unify_var env (newvar()) ty_arg;
+            (try unify_var env (newvar()) ty_arg with Unify _ -> assert false);
             lower_args (ty::seen) ty_fun
         | _ -> ()
       in
-      let ty = instance funct.exp_type in
+      let ty = instance env funct.exp_type in
       end_def ();
       lower_args [] ty;
       begin_def ();
       let (args, ty_res) = type_application env funct sargs in
       end_def ();
       unify_var env (newvar()) funct.exp_type;
-      re {
+      rue {
         exp_desc = Texp_apply(funct, args);
         exp_loc = loc;
         exp_type = ty_res;
         exp_env = env }
   | Pexp_match(sarg, caselist) ->
+      begin_def ();
       let arg = type_exp env sarg in
-      let ty_res = newvar() in
+      end_def ();
+      if is_nonexpansive arg then generalize arg.exp_type
+      else generalize_expansive env arg.exp_type;
       let cases, partial =
-        type_cases env arg.exp_type ty_res (Some loc) caselist
+        type_cases env arg.exp_type ty_expected true loc caselist
       in
       re {
         exp_desc = Texp_match(arg, cases, partial);
         exp_loc = loc;
-        exp_type = ty_res;
+        exp_type = instance env ty_expected;
         exp_env = env }
   | Pexp_try(sbody, caselist) ->
-      let body = type_exp env sbody in
+      let body = type_expect env sbody ty_expected in
       let cases, _ =
-        type_cases
-          env (instance Predef.type_exn) body.exp_type None caselist in
+        type_cases env Predef.type_exn ty_expected false loc caselist in
       re {
         exp_desc = Texp_try(body, cases);
         exp_loc = loc;
         exp_type = body.exp_type;
         exp_env = env }
   | Pexp_tuple sexpl ->
-      let expl = List.map (type_exp env) sexpl in
+      let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
+      let to_unify = newgenty (Ttuple subtypes) in
+      unify_exp_types loc env to_unify ty_expected;
+      let expl =
+        List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes
+      in
       re {
         exp_desc = Texp_tuple expl;
         exp_loc = loc;
-        exp_type = newty (Ttuple(List.map (fun exp -> exp.exp_type) expl));
+        (* Keep sharing *)
+        exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl));
         exp_env = env }
   | Pexp_construct(lid, sarg, explicit_arity) ->
-      type_construct env loc lid sarg explicit_arity (newvar ())
+      type_construct env loc lid sarg explicit_arity ty_expected
   | Pexp_variant(l, sarg) ->
-      let arg = may_map (type_exp env) sarg in
-      let arg_type = may_map (fun arg -> arg.exp_type) arg in
-      re {
-        exp_desc = Texp_variant(l, arg);
-        exp_loc = loc;
-        exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
-                                  row_more = newvar ();
-                                  row_bound = ();
-                                  row_closed = false;
-                                  row_fixed = false;
-                                  row_name = None});
-        exp_env = env }
+      (* Keep sharing *)
+      let ty_expected0 = instance env ty_expected in
+      begin try match
+        sarg, expand_head env ty_expected, expand_head env ty_expected0 with
+      | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} ->
+          let row = row_repr row in
+          begin match row_field_repr (List.assoc l row.row_fields),
+          row_field_repr (List.assoc l row0.row_fields) with
+            Rpresent (Some ty), Rpresent (Some ty0) ->
+              let arg = type_argument env sarg ty ty0 in
+              re { exp_desc = Texp_variant(l, Some arg);
+                   exp_loc = loc;
+                   exp_type = ty_expected0;
+                   exp_env = env }
+          | _ -> raise Not_found
+          end
+      | _ -> raise Not_found
+      with Not_found ->
+        let arg = may_map (type_exp env) sarg in
+        let arg_type = may_map (fun arg -> arg.exp_type) arg in
+        rue {
+          exp_desc = Texp_variant(l, arg);
+          exp_loc = loc;
+          exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
+                                    row_more = newvar ();
+                                    row_bound = ();
+                                    row_closed = false;
+                                    row_fixed = false;
+                                    row_name = None});
+          exp_env = env }
+      end
   | Pexp_record(lid_sexp_list, opt_sexp) ->
-      let ty = newvar () in
       let lbl_exp_list =
-        type_label_a_list (type_label_exp true env loc ty) lid_sexp_list in
+        type_label_a_list env loc (type_label_exp true env loc ty_expected)
+          lid_sexp_list in
       let rec check_duplicates seen_pos lid_sexp lbl_exp =
         match (lid_sexp, lbl_exp) with
           ((lid, _) :: rem1, (lbl, _) :: rem2) ->
@@ -1174,6 +1715,7 @@ let rec type_exp env sexp =
         match opt_sexp, lbl_exp_list with
           None, _ -> None
         | Some sexp, (lbl, _) :: _ ->
+            if !Clflags.principal then begin_def ();
             let ty_exp = newvar () in
             let unify_kept lbl =
               if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
@@ -1182,10 +1724,14 @@ let rec type_exp env sexp =
                 let _, ty_arg1, ty_res1 = instance_label false lbl
                 and _, ty_arg2, ty_res2 = instance_label false lbl in
                 unify env ty_exp ty_res1;
-                unify env ty ty_res2;
+                unify env (instance env ty_expected) ty_res2;
                 unify env ty_arg1 ty_arg2
               end in
             Array.iter unify_kept lbl.lbl_all;
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty_exp
+            end;
             Some(type_expect env sexp ty_exp)
         | _ -> assert false
       in
@@ -1195,7 +1741,7 @@ let rec type_exp env sexp =
       if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin
         let present_indices =
           List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in
-        let label_names = extract_label_names sexp env ty in
+        let label_names = extract_label_names sexp env ty_expected in
         let rec missing_labels n = function
             [] -> []
           | lbl :: rem ->
@@ -1210,50 +1756,55 @@ let rec type_exp env sexp =
       re {
         exp_desc = Texp_record(lbl_exp_list, opt_exp);
         exp_loc = loc;
-        exp_type = ty;
+        exp_type = instance env ty_expected;
         exp_env = env }
   | Pexp_field(sarg, lid) ->
       let arg = type_exp env sarg in
       let label = Typetexp.find_label env loc lid in
       let (_, ty_arg, ty_res) = instance_label false label in
       unify_exp env arg ty_res;
-      re {
+      rue {
         exp_desc = Texp_field(arg, label);
         exp_loc = loc;
         exp_type = ty_arg;
         exp_env = env }
   | Pexp_setfield(srecord, lid, snewval) ->
       let record = type_exp env srecord in
+      let label = Typetexp.find_label env loc lid in
       let (label, newval) =
-        type_label_exp false env loc record.exp_type (lid, snewval) in
+        type_label_exp false env loc record.exp_type (label, snewval) in
       if label.lbl_mut = Immutable then
         raise(Error(loc, Label_not_mutable lid));
-      re {
+      rue {
         exp_desc = Texp_setfield(record, label, newval);
         exp_loc = loc;
-        exp_type = instance Predef.type_unit;
+        exp_type = instance_def Predef.type_unit;
         exp_env = env }
   | Pexp_array(sargl) ->
-      let ty = newvar() in
+      let ty = newgenvar() in
+      let to_unify = Predef.type_array ty in
+      unify_exp_types loc env to_unify ty_expected;
       let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
       re {
         exp_desc = Texp_array argl;
         exp_loc = loc;
-        exp_type = instance (Predef.type_array ty);
+        exp_type = instance env ty_expected;
         exp_env = env }
   | Pexp_ifthenelse(scond, sifso, sifnot) ->
-      let cond = type_expect env scond (instance Predef.type_bool) in
+      let cond = type_expect env scond Predef.type_bool in
       begin match sifnot with
         None ->
-          let ifso = type_expect env sifso (instance Predef.type_unit) in
-          re {
+          let ifso = type_expect env sifso Predef.type_unit in
+          rue {
             exp_desc = Texp_ifthenelse(cond, ifso, None);
             exp_loc = loc;
-            exp_type = instance Predef.type_unit;
+            exp_type = ifso.exp_type;
             exp_env = env }
       | Some sifnot ->
-          let ifso = type_exp env sifso in
-          let ifnot = type_expect env sifnot ifso.exp_type in
+          let ifso = type_expect env sifso ty_expected in
+          let ifnot = type_expect env sifnot ty_expected in
+          (* Keep sharing *)
+          unify_exp env ifnot ifso.exp_type;
           re {
             exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
             exp_loc = loc;
@@ -1262,56 +1813,61 @@ let rec type_exp env sexp =
       end
   | Pexp_sequence(sexp1, sexp2) ->
       let exp1 = type_statement env sexp1 in
-      let exp2 = type_exp env sexp2 in
+      let exp2 = type_expect env sexp2 ty_expected in
       re {
         exp_desc = Texp_sequence(exp1, exp2);
         exp_loc = loc;
         exp_type = exp2.exp_type;
         exp_env = env }
   | Pexp_while(scond, sbody) ->
-      let cond = type_expect env scond (instance Predef.type_bool) in
+      let cond = type_expect env scond Predef.type_bool in
       let body = type_statement env sbody in
-      re {
+      rue {
         exp_desc = Texp_while(cond, body);
         exp_loc = loc;
-        exp_type = instance Predef.type_unit;
+        exp_type = instance_def Predef.type_unit;
         exp_env = env }
   | Pexp_for(param, slow, shigh, dir, sbody) ->
-      let low = type_expect env slow (instance Predef.type_int) in
-      let high = type_expect env shigh (instance Predef.type_int) in
+      let low = type_expect env slow Predef.type_int in
+      let high = type_expect env shigh Predef.type_int in
       let (id, new_env) =
-        Env.enter_value param {val_type = instance Predef.type_int;
-                                val_kind = Val_reg} env in
+        Env.enter_value param {val_type = instance_def Predef.type_int;
+                               val_kind = Val_reg;
+                               val_loc = loc;
+                              } env
+          ~check:(fun s -> Warnings.Unused_for_index s)
+      in
       let body = type_statement new_env sbody in
-      re {
+      rue {
         exp_desc = Texp_for(id, low, high, dir, body);
         exp_loc = loc;
-        exp_type = instance Predef.type_unit;
+        exp_type = instance_def Predef.type_unit;
         exp_env = env }
   | Pexp_constraint(sarg, sty, sty') ->
+      let separate = true (* always separate, 1% slowdown for lablgtk *)
+        (* !Clflags.principal || Env.has_local_constraints env *) in
       let (arg, ty') =
         match (sty, sty') with
           (None, None) ->               (* Case actually unused *)
             let arg = type_exp env sarg in
             (arg, arg.exp_type)
         | (Some sty, None) ->
-            if !Clflags.principal then begin_def ();
+            if separate then begin_def ();
             let ty = Typetexp.transl_simple_type env false sty in
-            if !Clflags.principal then begin
+            if separate then begin
               end_def ();
               generalize_structure ty;
-              let ty1 = instance ty and ty2 = instance ty in
-              (type_expect env sarg ty1, ty2)
+              (type_argument env sarg ty (instance env ty), instance env ty)
             end else
-              (type_expect env sarg ty, ty)
+              (type_argument env sarg ty ty, ty)
         | (None, Some sty') ->
             let (ty', force) =
               Typetexp.transl_simple_type_delayed env sty'
             in
-            if !Clflags.principal then begin_def ();
+            if separate then begin_def ();
             let arg = type_exp env sarg in
             let gen =
-              if !Clflags.principal then begin
+              if separate then begin
                 end_def ();
                 let tv = newvar () in
                 let gen = generalizable tv.level arg.exp_type in
@@ -1355,6 +1911,7 @@ let rec type_exp env sexp =
             end;
             (arg, ty')
         | (Some sty, Some sty') ->
+            if separate then begin_def ();
             let (ty, force) =
               Typetexp.transl_simple_type_delayed env sty
             and (ty', force') =
@@ -1366,16 +1923,22 @@ let rec type_exp env sexp =
             with Subtype (tr1, tr2) ->
               raise(Error(loc, Not_subtype(tr1, tr2)))
             end;
-            (type_expect env sarg ty, ty')
+            if separate then begin
+              end_def ();
+              generalize_structure ty;
+              generalize_structure ty';
+              (type_argument env sarg ty (instance env ty), instance env ty')
+            end else
+              (type_argument env sarg ty ty, ty')
       in
-      re {
+      rue {
         exp_desc = arg.exp_desc;
         exp_loc = arg.exp_loc;
         exp_type = ty';
         exp_env = env }
   | Pexp_when(scond, sbody) ->
-      let cond = type_expect env scond (instance Predef.type_bool) in
-      let body = type_exp env sbody in
+      let cond = type_expect env scond Predef.type_bool in
+      let body = type_expect env sbody ty_expected in
       re {
         exp_desc = Texp_when(cond, body);
         exp_loc = loc;
@@ -1391,7 +1954,7 @@ let rec type_exp env sexp =
               let (id, typ) =
                 filter_self_method env met Private meths privty
               in
-              if (repr typ).desc = Tvar then
+              if is_Tvar (repr typ) then
                 Location.prerr_warning loc
                   (Warnings.Undeclared_virtual_method met);
               (Texp_send(obj, Tmeth_val id), typ)
@@ -1413,10 +1976,12 @@ let rec type_exp env sexp =
                   let method_type = newvar () in
                   let (obj_ty, res_ty) = filter_arrow env method_type "" in
                   unify env obj_ty desc.val_type;
-                  unify env res_ty (instance typ);
+                  unify env res_ty (instance env typ);
                   (Texp_apply({ exp_desc = Texp_ident(Path.Pident method_id,
                                                      {val_type = method_type;
-                                                       val_kind = Val_reg});
+                                                      val_kind = Val_reg;
+                                                      val_loc = Location.none;
+                                                     });
                                 exp_loc = loc;
                                 exp_type = method_type;
                                 exp_env = env },
@@ -1440,26 +2005,26 @@ let rec type_exp env sexp =
         let typ =
           match repr typ with
             {desc = Tpoly (ty, [])} ->
-              instance ty
+              instance env ty
           | {desc = Tpoly (ty, tl); level = l} ->
               if !Clflags.principal && l <> generic_level then
                 Location.prerr_warning loc
                   (Warnings.Not_principal "this use of a polymorphic method");
               snd (instance_poly false tl ty)
-          | {desc = Tvar} as ty ->
+          | {desc = Tvar _} as ty ->
               let ty' = newvar () in
-              unify env (instance ty) (newty(Tpoly(ty',[])));
+              unify env (instance_def ty) (newty(Tpoly(ty',[])));
               (* if not !Clflags.nolabels then
                  Location.prerr_warning loc (Warnings.Unknown_method met); *)
               ty'
           | _ ->
               assert false
         in
-          re {
-            exp_desc = exp;
-            exp_loc = loc;
-            exp_type = typ;
-            exp_env = env }
+        rue {
+          exp_desc = exp;
+          exp_loc = loc;
+          exp_type = typ;
+          exp_env = env }
       with Unify _ ->
         raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
       end
@@ -1469,10 +2034,10 @@ let rec type_exp env sexp =
           None ->
             raise(Error(loc, Virtual_class cl))
         | Some ty ->
-            re {
+            rue {
               exp_desc = Texp_new (cl_path, cl_decl);
               exp_loc = loc;
-              exp_type = instance ty;
+              exp_type = instance_def ty;
               exp_env = env }
         end
   | Pexp_setinstvar (lab, snewval) ->
@@ -1480,14 +2045,14 @@ let rec type_exp env sexp =
         let (path, desc) = Env.lookup_value (Longident.Lident lab) env in
         match desc.val_kind with
           Val_ivar (Mutable, cl_num) ->
-            let newval = type_expect env snewval (instance desc.val_type) in
+            let newval = type_expect env snewval (instance env desc.val_type) in
             let (path_self, _) =
               Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
             in
-            re {
+            rue {
               exp_desc = Texp_setinstvar(path_self, path, newval);
               exp_loc = loc;
-              exp_type = instance Predef.type_unit;
+              exp_type = instance_def Predef.type_unit;
               exp_env = env }
         | Val_ivar _ ->
             raise(Error(loc,Instance_variable_not_mutable(true,lab)))
@@ -1519,14 +2084,14 @@ let rec type_exp env sexp =
           let type_override (lab, snewval) =
             begin try
               let (id, _, _, ty) = Vars.find lab !vars in
-              (Path.Pident id, type_expect env snewval (instance ty))
+              (Path.Pident id, type_expect env snewval (instance env ty))
             with
               Not_found ->
                 raise(Error(loc, Unbound_instance_variable lab))
             end
           in
           let modifs = List.map type_override lst in
-          re {
+          rue {
             exp_desc = Texp_override(path_self, modifs);
             exp_loc = loc;
             exp_type = self_ty;
@@ -1536,20 +2101,24 @@ let rec type_exp env sexp =
       end
   | Pexp_letmodule(name, smodl, sbody) ->
       let ty = newvar() in
+      (* remember original level *)
+      begin_def ();
       Ident.set_current_time ty.level;
       let context = Typetexp.narrow () in
       let modl = !type_module env smodl in
       let (id, new_env) = Env.enter_module name modl.mod_type env in
       Ctype.init_def(Ident.current_time());
       Typetexp.widen context;
-      let body = type_exp new_env sbody in
+      let body = type_expect new_env sbody ty_expected in
+      (* go back to original level *)
+      end_def ();
       (* Unification of body.exp_type with the fresh variable ty
          fails if and only if the prefix condition is violated,
          i.e. if generative types rooted at id show up in the
          type body.exp_type.  Thus, this unification enforces the
          scoping condition on "let module". *)
       begin try
-        Ctype.unify new_env body.exp_type ty
+        Ctype.unify_var new_env ty body.exp_type
       with Unify _ ->
         raise(Error(loc, Scoping_let_module(name, body.exp_type)))
       end;
@@ -1559,40 +2128,81 @@ let rec type_exp env sexp =
         exp_type = ty;
         exp_env = env }
   | Pexp_assert (e) ->
-       let cond = type_expect env e (instance Predef.type_bool) in
-       re {
-         exp_desc = Texp_assert (cond);
-         exp_loc = loc;
-         exp_type = instance Predef.type_unit;
-         exp_env = env;
-       }
+      let cond = type_expect env e Predef.type_bool in
+      rue {
+        exp_desc = Texp_assert (cond);
+        exp_loc = loc;
+        exp_type = instance_def Predef.type_unit;
+        exp_env = env;
+      }
   | Pexp_assertfalse ->
-       re {
-         exp_desc = Texp_assertfalse;
-         exp_loc = loc;
-         exp_type = newvar ();
-         exp_env = env;
-       }
+      re {
+        exp_desc = Texp_assertfalse;
+        exp_loc = loc;
+        exp_type = instance env ty_expected;
+        exp_env = env;
+      }
   | Pexp_lazy e ->
-       let arg = type_exp env e in
-       re {
-         exp_desc = Texp_lazy arg;
-         exp_loc = loc;
-         exp_type = instance (Predef.type_lazy_t arg.exp_type);
-         exp_env = env;
-       }
+      let ty = newgenvar () in
+      let to_unify = Predef.type_lazy_t ty in
+      unify_exp_types loc env to_unify ty_expected;
+      let arg = type_expect env e ty in
+      re {
+        exp_desc = Texp_lazy arg;
+        exp_loc = loc;
+        exp_type = instance env ty_expected;
+        exp_env = env;
+      }
   | Pexp_object s ->
       let desc, sign, meths = !type_object env loc s in
-      re {
+      rue {
         exp_desc = Texp_object (desc, sign, meths);
         exp_loc = loc;
         exp_type = sign.cty_self;
         exp_env = env;
       }
-  | Pexp_poly _ ->
-      assert false
+  | Pexp_poly(sbody, sty) ->
+      if !Clflags.principal then begin_def ();
+      let ty =
+        match sty with None -> repr ty_expected
+        | Some sty ->
+            let ty = Typetexp.transl_simple_type env false sty in
+            repr ty
+      in
+      if !Clflags.principal then begin
+        end_def ();
+        generalize_structure ty
+      end;
+      if sty <> None then
+        unify_exp_types loc env (instance env ty) (instance env ty_expected);
+      begin
+        match (expand_head env ty).desc with
+          Tpoly (ty', []) ->
+            let exp = type_expect env sbody ty' in
+            re { exp with exp_type = instance env ty }
+        | Tpoly (ty', tl) ->
+            (* One more level to generalize locally *)
+            begin_def ();
+            if !Clflags.principal then begin_def ();
+            let vars, ty'' = instance_poly true tl ty' in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty''
+            end;
+            let exp = type_expect env sbody ty'' in
+            end_def ();
+            check_univars env false "method" exp ty_expected vars;
+            re { exp with exp_type = instance env ty }
+        | Tvar _ ->
+            let exp = type_exp env sbody in
+            let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
+            unify_exp env exp ty;
+            re exp
+        | _ -> assert false
+      end
   | Pexp_newtype(name, sbody) ->
       (* Create a fake abstract type declaration for name. *)
+      let level = get_current_level () in
       let decl = {
         type_params = [];
         type_arity = 0;
@@ -1600,16 +2210,20 @@ let rec type_exp env sexp =
         type_private = Public;
         type_manifest = None;
         type_variance = [];
+        type_newtype_level = Some (level, level);
+        type_loc = loc;
       }
       in
-
       let ty = newvar () in
+      (* remember original level *)
+      begin_def ();
       Ident.set_current_time ty.level;
       let (id, new_env) = Env.enter_type name decl env in
       Ctype.init_def(Ident.current_time());
 
       let body = type_exp new_env sbody in
-      (* Replace every instance of this type constructor in the resulting type. *)
+      (* Replace every instance of this type constructor in the resulting
+         type. *)
       let seen = Hashtbl.create 8 in
       let rec replace t =
         if Hashtbl.mem seen t.id then ()
@@ -1622,45 +2236,68 @@ let rec type_exp env sexp =
       in
       let ety = Subst.type_expr Subst.identity body.exp_type in
       replace ety;
+      (* back to original level *)
+      end_def ();
+      (* lower the levels of the result type *)
+      (* unify_var env ty ety; *)
 
       (* non-expansive if the body is non-expansive, so we don't introduce
          any new extra node in the typed AST. *)
-      re { body with exp_loc = sexp.pexp_loc; exp_type = ety }
-  | Pexp_pack (m, (p, l)) ->
-      let loc = sexp.pexp_loc in
-      let l, mty = Typetexp.create_package_mty loc env (p, l) in
-      let m = {pmod_desc = Pmod_constraint (m, mty); pmod_loc = loc} in
-      let context = Typetexp.narrow () in
-      let modl = !type_module env m in
-      Typetexp.widen context;
-      re {
+      rue { body with exp_loc = sexp.pexp_loc; exp_type = ety }
+  | Pexp_pack m ->
+      let (p, nl, tl) =
+        match Ctype.expand_head env (instance env ty_expected) with
+          {desc = Tpackage (p, nl, tl)} ->
+            if !Clflags.principal &&
+              (Ctype.expand_head env ty_expected).level < Btype.generic_level
+            then
+              Location.prerr_warning loc
+                (Warnings.Not_principal "this module packing");
+            (p, nl, tl)
+        | {desc = Tvar _} ->
+            raise (Error (loc, Cannot_infer_signature))
+        | _ ->
+            raise (Error (loc, Not_a_packed_module ty_expected))
+      in
+      let (modl, tl') = !type_package env m p nl tl in
+      rue {
         exp_desc = Texp_pack modl;
         exp_loc = loc;
-        exp_type = create_package_type loc env (p, l);
+        exp_type = newty (Tpackage (p, nl, tl'));
         exp_env = env }
   | Pexp_open (lid, e) ->
-      type_exp (!type_open env sexp.pexp_loc lid) e
+      type_expect (!type_open env sexp.pexp_loc lid) e ty_expected
 
-and type_label_exp create env loc ty (lid, sarg) =
-  let label = Typetexp.find_label env sarg.pexp_loc lid in
+and type_label_exp create env loc ty_expected (label, sarg) =
+  (* Here also ty_expected may be at generic_level *)
   begin_def ();
-  if !Clflags.principal then begin_def ();
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
   let (vars, ty_arg, ty_res) = instance_label true label in
-  if !Clflags.principal then begin
+  if separate then begin
     end_def ();
+    (* Generalize label information *)
     generalize_structure ty_arg;
     generalize_structure ty_res
   end;
   begin try
-    unify env (instance ty_res) ty
+    unify env (instance_def ty_res) (instance env ty_expected)
   with Unify trace ->
-    raise(Error(loc , Label_mismatch(lid, trace)))
+    raise(Error(loc , Label_mismatch(lid_of_label label, trace)))
+  end;
+  (* Instantiate so that we can generalize internal nodes *)
+  let ty_arg = instance_def ty_arg in
+  if separate then begin
+    end_def ();
+    (* Generalize information merged from ty_expected *)
+    generalize_structure ty_arg
   end;
   if label.lbl_private = Private then
-    raise(Error(loc, if create then Private_type ty else Private_label (lid, ty)));
+    raise(Error(loc, if create then Private_type ty_expected
+                     else Private_label (lid_of_label label, ty_expected)));
   let arg =
     let snap = if vars = [] then None else Some (Btype.snapshot ()) in
-    let arg = type_argument env sarg ty_arg in
+    let arg = type_argument env sarg ty_arg (instance env ty_arg) in
     end_def ();
     try
       check_univars env (vars <> []) "field value" arg label.lbl_arg vars;
@@ -1678,19 +2315,22 @@ and type_label_exp create env loc ty (lid, sarg) =
     with Error (_, Less_general _) as e -> raise e
     | _ -> raise exn    (* In case of failure return the first error *)
   in
-  (label, {arg with exp_type = instance arg.exp_type})
+  (label, {arg with exp_type = instance env arg.exp_type})
 
-and type_argument env sarg ty_expected' =
+and type_argument env sarg ty_expected' ty_expected =
   (* ty_expected' may be generic *)
   let no_labels ty =
     let ls, tvar = list_labels env ty in
     not tvar && List.for_all ((=) "") ls
   in
-  let ty_expected = instance ty_expected' in
-  match expand_head env ty_expected', sarg with
-  | _, {pexp_desc = Pexp_function(l,_,_)} when not (is_optional l) ->
-      type_expect env sarg ty_expected
-  | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ ->
+  let rec is_inferred sexp =
+    match sexp.pexp_desc with
+      Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true
+    | Pexp_open (_, e) -> is_inferred e
+    | _ -> false
+  in
+  match expand_head env ty_expected' with
+    {desc = Tarrow("",ty_arg,ty_res,_); level = lv} when is_inferred sarg ->
       (* apply optional arguments when expected type is "" *)
       (* we must be very careful about not breaking the semantics *)
       if !Clflags.principal then begin_def ();
@@ -1703,19 +2343,19 @@ and type_argument env sarg ty_expected' =
         match (expand_head env ty_fun).desc with
         | Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
             make_args
-              ((Some(option_none (instance ty_arg) sarg.pexp_loc), Optional)
+              ((Some(option_none (instance env ty_arg) sarg.pexp_loc), Optional)
                :: args)
               ty_fun
         | Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
             args, ty_fun, no_labels ty_res'
-        | Tvar ->  args, ty_fun, false
+        | Tvar _ ->  args, ty_fun, false
         |  _ -> [], texp.exp_type, false
       in
       let args, ty_fun', simple_res = make_args [] texp.exp_type in
       let warn = !Clflags.principal &&
         (lv <> generic_level || (repr ty_fun').level <> generic_level)
-      and texp = {texp with exp_type = instance texp.exp_type}
-      and ty_fun = instance ty_fun' in
+      and texp = {texp with exp_type = instance env texp.exp_type}
+      and ty_fun = instance env ty_fun' in
       if not (simple_res || no_labels ty_res) then begin
         unify_exp env texp ty_expected;
         texp
@@ -1728,7 +2368,8 @@ and type_argument env sarg ty_expected' =
         {pat_desc = Tpat_var id; pat_type = ty;
          pat_loc = Location.none; pat_env = env},
         {exp_type = ty; exp_loc = Location.none; exp_env = env; exp_desc =
-         Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg})}
+         Texp_ident(Path.Pident id, {val_type = ty; val_kind = Val_reg;
+                                     val_loc = Location.none})}
       in
       let eta_pat, eta_var = var_pair "eta" ty_arg in
       let func texp =
@@ -1746,7 +2387,9 @@ and type_argument env sarg ty_expected' =
            Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
       end
   | _ ->
-      type_expect env sarg ty_expected
+      let texp = type_expect env sarg ty_expected' in
+      unify_exp env texp ty_expected;
+      texp
 
 and type_application env funct sargs =
   (* funct.exp_type may be generic *)
@@ -1765,12 +2408,12 @@ and type_application env funct sargs =
         (List.map
            (function None, x -> None, x | Some f, x -> Some (f ()), x)
            (List.rev args),
-         instance (result_type omitted ty_fun))
+         instance env (result_type omitted ty_fun))
     | (l1, sarg1) :: sargl ->
         let (ty1, ty2) =
           let ty_fun = expand_head env ty_fun in
           match ty_fun.desc with
-            Tvar ->
+            Tvar _ ->
               let t1 = newvar () and t2 = newvar () in
               let not_identity = function
                   Texp_ident(_,{val_kind=Val_prim
@@ -1822,9 +2465,10 @@ and type_application env funct sargs =
     end
   in
   let warned = ref false in
-  let rec type_args args omitted ty_fun ty_old sargs more_sargs =
-    match expand_head env ty_fun with
-      {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun'
+  let rec type_args args omitted ty_fun ty_fun0 ty_old sargs more_sargs =
+    match expand_head env ty_fun, expand_head env ty_fun0 with
+      {desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun',
+      {desc=Tarrow (_, ty0, ty_fun0, _)}
       when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
         let may_warn loc w =
           if not !warned && !Clflags.principal && lv <> generic_level
@@ -1845,7 +2489,8 @@ and type_application env funct sargs =
                 if l <> l' && l' <> "" then
                   raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
                 else
-                  ([], more_sargs, Some (fun () -> type_argument env sarg0 ty))
+                  ([], more_sargs,
+                   Some (fun () -> type_argument env sarg0 ty ty0))
             | _ ->
                 assert false
           end else try
@@ -1866,12 +2511,13 @@ and type_application env funct sargs =
             in
             sargs, more_sargs,
             if optional = Required || is_optional l' then
-              Some (fun () -> type_argument env sarg0 ty)
+              Some (fun () -> type_argument env sarg0 ty ty0)
             else begin
               may_warn sarg0.pexp_loc
                 (Warnings.Not_principal "using an optional argument here");
               Some (fun () -> option_some (type_argument env sarg0
-                                             (extract_option_type env ty)))
+                                             (extract_option_type env ty)
+                                             (extract_option_type env ty0)))
             end
           with Not_found ->
             sargs, more_sargs,
@@ -1881,7 +2527,7 @@ and type_application env funct sargs =
               may_warn funct.exp_loc
                 (Warnings.Without_principality "eliminated optional argument");
               ignored := (l,ty,lv) :: !ignored;
-              Some (fun () -> option_none (instance ty) Location.none)
+              Some (fun () -> option_none (instance env ty) Location.none)
             end else begin
               may_warn funct.exp_loc
                 (Warnings.Without_principality "commuted an argument");
@@ -1891,25 +2537,26 @@ and type_application env funct sargs =
         let omitted =
           if arg = None then (l,ty,lv) :: omitted else omitted in
         let ty_old = if sargs = [] then ty_fun else ty_old in
-        type_args ((arg,optional)::args) omitted ty_fun ty_old sargs more_sargs
+        type_args ((arg,optional)::args) omitted ty_fun ty_fun0
+          ty_old sargs more_sargs
     | _ ->
         match sargs with
           (l, sarg0) :: _ when ignore_labels ->
             raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
         | _ ->
-            type_unknown_args args omitted (instance ty_fun)
+            type_unknown_args args omitted ty_fun0
               (sargs @ more_sargs)
   in
   match funct.exp_desc, sargs with
     (* Special case for ignore: avoid discarding warning *)
     Texp_ident (_, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}),
     ["", sarg] ->
-      let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) "" in
+      let ty_arg, ty_res = filter_arrow env (instance env funct.exp_type) "" in
       let exp = type_expect env sarg ty_arg in
       begin match (expand_head env exp.exp_type).desc with
       | Tarrow _ ->
           Location.prerr_warning exp.exp_loc Warnings.Partial_application
-      | Tvar ->
+      | Tvar _ ->
           add_delayed_check (fun () -> check_application_result env false exp)
       | _ -> ()
       end;
@@ -1917,12 +2564,13 @@ and type_application env funct sargs =
   | _ ->
       let ty = funct.exp_type in
       if ignore_labels then
-        type_args [] [] ty ty [] sargs
+        type_args [] [] ty (instance env ty) ty [] sargs
       else
-        type_args [] [] ty ty sargs []
+        type_args [] [] ty (instance env ty) ty sargs []
 
 and type_construct env loc lid sarg explicit_arity ty_expected =
   let constr = Typetexp.find_constructor env loc lid in
+  Env.mark_constructor `Positive env (Longident.last lid) constr;
   let sargs =
     match sarg with
       None -> []
@@ -1932,188 +2580,36 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
   if List.length sargs <> constr.cstr_arity then
     raise(Error(loc, Constructor_arity_mismatch
                   (lid, constr.cstr_arity, List.length sargs)));
-  if !Clflags.principal then begin_def ();
+  let separate = !Clflags.principal || Env.has_local_constraints env in
+  if separate then (begin_def (); begin_def ());
   let (ty_args, ty_res) = instance_constructor constr in
-  if !Clflags.principal then begin
-    end_def ();
-    List.iter generalize_structure ty_args;
-    generalize_structure ty_res
-  end;
   let texp =
     re {
       exp_desc = Texp_construct(constr, []);
       exp_loc = loc;
-      exp_type = instance ty_res;
+      exp_type = ty_res;
       exp_env = env } in
-  unify_exp env texp ty_expected;
-  let args = List.map2 (type_argument env) sargs ty_args in
+  if separate then begin
+    end_def ();
+    generalize_structure ty_res;
+    unify_exp env {texp with exp_type = instance_def ty_res}
+                  (instance env ty_expected);
+    end_def ();
+    List.iter generalize_structure ty_args;
+    generalize_structure ty_res;
+  end;
+  let ty_args0, ty_res =
+    match instance_list env (ty_res :: ty_args) with
+      t :: tl -> tl, t
+    | _ -> assert false
+  in
+  let texp = {texp with exp_type = ty_res} in
+  if not separate then unify_exp env texp (instance env ty_expected);
+  let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs
+      (List.combine ty_args ty_args0) in
   if constr.cstr_private = Private then
     raise(Error(loc, Private_type ty_res));
-  { texp with exp_desc = Texp_construct(constr, args) }
-
-(* Typing of an expression with an expected type.
-   Some constructs are treated specially to provide better error messages. *)
-
-and type_expect ?in_function env sexp ty_expected =
-  let loc = sexp.pexp_loc in
-  match sexp.pexp_desc with
-    Pexp_constant(Const_string s as cst) ->
-      let exp =
-        re {
-          exp_desc = Texp_constant cst;
-          exp_loc = loc;
-          exp_type =
-            (* Terrible hack for format strings *)
-            begin match (repr (expand_head env ty_expected)).desc with
-              Tconstr(path, _, _) when Path.same path Predef.path_format6 ->
-                type_format loc s
-            | _ -> instance Predef.type_string
-            end;
-          exp_env = env } in
-      unify_exp env exp ty_expected;
-      exp
-  | Pexp_construct(lid, sarg, explicit_arity) ->
-      type_construct env loc lid sarg explicit_arity ty_expected
-  | Pexp_let(rec_flag, spat_sexp_list, sbody) ->
-      let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
-      let body = type_expect new_env sbody ty_expected in
-      re {
-        exp_desc = Texp_let(rec_flag, pat_exp_list, body);
-        exp_loc = loc;
-        exp_type = body.exp_type;
-        exp_env = env }
-  | Pexp_sequence(sexp1, sexp2) ->
-      let exp1 = type_statement env sexp1 in
-      let exp2 = type_expect env sexp2 ty_expected in
-      re {
-        exp_desc = Texp_sequence(exp1, exp2);
-        exp_loc = loc;
-        exp_type = exp2.exp_type;
-        exp_env = env }
-  | Pexp_function (l, Some default, [spat, sbody]) ->
-      let default_loc = default.pexp_loc in
-      let scases = [
-         {ppat_loc = default_loc;
-          ppat_desc =
-            Ppat_construct
-              (Longident.(Ldot (Lident "*predef*", "Some")),
-               Some {ppat_loc = default_loc; ppat_desc = Ppat_var "*sth*"},
-               false)},
-         {pexp_loc = default_loc;
-          pexp_desc = Pexp_ident(Longident.Lident "*sth*")};
-         {ppat_loc = default_loc;
-          ppat_desc = Ppat_construct
-            (Longident.(Ldot (Lident "*predef*", "None")), None, false)},
-         default;
-      ] in
-      let smatch = {
-        pexp_loc = loc;
-        pexp_desc =
-          Pexp_match ({
-            pexp_loc = loc;
-            pexp_desc =
-              Pexp_ident(Longident.Lident "*opt*")
-            },
-            scases
-          )
-      } in
-      let sfun = {
-        pexp_loc = loc;
-        pexp_desc =
-         Pexp_function (
-           l,
-           None,
-           [ {ppat_loc = loc;
-              ppat_desc = Ppat_var "*opt*"},
-             {pexp_loc = loc;
-              pexp_desc =
-                Pexp_let(Default, [spat, smatch], sbody);
-             }
-           ]
-         )
-      } in
-      type_expect ?in_function env sfun ty_expected
-  | Pexp_function (l, _, caselist) ->
-      let (loc_fun, ty_fun) =
-        match in_function with Some p -> p
-        | None -> (loc, ty_expected)
-      in
-      let (ty_arg, ty_res) =
-        try filter_arrow env ty_expected l
-        with Unify _ ->
-          match expand_head env ty_expected with
-            {desc = Tarrow _} as ty ->
-              raise(Error(loc, Abstract_wrong_label(l, ty)))
-          | _ ->
-              raise(Error(loc_fun,
-                          Too_many_arguments (in_function <> None, ty_fun)))
-      in
-      let ty_arg =
-        if is_optional l then
-          let tv = newvar() in
-          begin
-            try unify env ty_arg (type_option tv)
-            with Unify _ -> assert false
-          end;
-          type_option tv
-        else ty_arg
-      in
-      let cases, partial =
-        type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
-          (Some loc) caselist in
-      let not_function ty =
-        let ls, tvar = list_labels env ty in
-        ls = [] && not tvar
-      in
-      if is_optional l && not_function ty_res then
-        Location.prerr_warning (fst (List.hd cases)).pat_loc
-          Warnings.Unerasable_optional_argument;
-      re {
-        exp_desc = Texp_function(cases, partial);
-        exp_loc = loc;
-        exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok));
-        exp_env = env }
-  | Pexp_when(scond, sbody) ->
-      let cond = type_expect env scond (instance Predef.type_bool) in
-      let body = type_expect env sbody ty_expected in
-      re {
-        exp_desc = Texp_when(cond, body);
-        exp_loc = loc;
-        exp_type = body.exp_type;
-        exp_env = env }
-  | Pexp_poly(sbody, sty) ->
-      let ty =
-        match sty with None -> repr ty_expected
-        | Some sty ->
-            let ty = Typetexp.transl_simple_type env false sty in
-            repr ty
-      in
-      let set_type ty =
-        unify_exp env
-          { exp_desc = Texp_tuple [];
-            exp_loc = loc;
-            exp_type = ty; exp_env = env } ty_expected in
-      begin
-        match ty.desc with
-          Tpoly (ty', []) ->
-            if sty <> None then set_type ty;
-            let exp = type_expect env sbody ty' in
-            re { exp with exp_type = ty }
-        | Tpoly (ty', tl) ->
-            if sty <> None then set_type ty;
-            (* One more level to generalize locally *)
-            begin_def ();
-            let vars, ty'' = instance_poly true tl ty' in
-            let exp = type_expect env sbody ty'' in
-            end_def ();
-            check_univars env false "method" exp ty_expected vars;
-            re { exp with exp_type = ty }
-        | _ -> assert false
-      end
-  | _ ->
-      let exp = type_exp env sexp in
-      unify_exp env exp ty_expected;
-      exp
+  { texp with exp_desc = Texp_construct(constr, args)}
 
 (* Typing of statements (expressions whose values are discarded) *)
 
@@ -2123,7 +2619,7 @@ and type_statement env sexp =
   let exp = type_exp env sexp in
   end_def();
   if !Clflags.strict_sequence then
-    let expected_ty = instance Predef.type_unit in
+    let expected_ty = instance_def Predef.type_unit in
     unify_exp env exp expected_ty;
     exp else
   let ty = expand_head env exp.exp_type and tv = newvar() in
@@ -2131,9 +2627,9 @@ and type_statement env sexp =
   | Tarrow _ ->
       Location.prerr_warning loc Warnings.Partial_application
   | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
-  | Tvar when ty.level > tv.level ->
+  | Tvar _ when ty.level > tv.level ->
       Location.prerr_warning loc Warnings.Nonreturning_statement
-  | Tvar ->
+  | Tvar _ ->
       add_delayed_check (fun () -> check_application_result env true exp)
   | _ ->
       Location.prerr_warning loc Warnings.Statement_type
@@ -2143,26 +2639,58 @@ and type_statement env sexp =
 
 (* Typing of match cases *)
 
-and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
+and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
+  (* ty_arg is _fully_ generalized *)
+  let dont_propagate, has_gadts =
+    let patterns = List.map fst caselist in
+    List.exists contains_polymorphic_variant patterns,
+    List.exists (contains_gadt env) patterns in
+  (* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
+  let ty_arg, ty_res, env =
+    if has_gadts && not !Clflags.principal then
+      correct_levels ty_arg, correct_levels ty_res,
+      duplicate_ident_types loc caselist env
+    else ty_arg, ty_res, env in
+  let lev, env =
+    if has_gadts then begin
+      (* raise level for existentials *)
+      begin_def ();
+      Ident.set_current_time (get_current_level ()); 
+      let lev = Ident.current_time () in
+      Ctype.init_def (lev+1000);                 (* up to 1000 existentials *)
+      (lev, Env.add_gadt_instance_level lev env)
+    end else (get_current_level (), env)
+  in
+  (* if has_gadts then
+    Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res;*)
+  begin_def (); (* propagation of the argument *)
   let ty_arg' = newvar () in
   let pattern_force = ref [] in
+  (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
+    Printtyp.raw_type_expr ty_arg; *)
   let pat_env_list =
     List.map
       (fun (spat, sexp) ->
         let loc = sexp.pexp_loc in
-        if !Clflags.principal then begin_def ();
+        if !Clflags.principal then begin_def (); (* propagation of pattern *)
         let scope = Some (Annot.Idef loc) in
-        let (pat, ext_env, force) = type_pattern env spat scope in
+        let (pat, ext_env, force, unpacks) =
+          let partial =
+            if !Clflags.principal then Some false else None in
+          let ty_arg =
+            if dont_propagate then newvar () else instance ?partial env ty_arg
+          in type_pattern ~lev env spat scope ty_arg
+        in
         pattern_force := force @ !pattern_force;
         let pat =
           if !Clflags.principal then begin
             end_def ();
             iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
-            { pat with pat_type = instance pat.pat_type }
+            { pat with pat_type = instance env pat.pat_type }
           end else pat
         in
         unify_pat env pat ty_arg';
-        (pat, ext_env))
+        (pat, (ext_env, unpacks)))
       caselist in
   (* Check for polymorphic variants to close *)
   let patl = List.map fst pat_env_list in
@@ -2172,76 +2700,202 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
   end;
   (* `Contaminating' unifications start here *)
   List.iter (fun f -> f()) !pattern_force;
-  begin match pat_env_list with [] -> ()
-  | (pat, _) :: _ -> unify_pat env pat ty_arg
-  end;
+  (* Post-processing and generalization *)
+  let patl = List.map fst pat_env_list in
+  List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar())))
+    patl;
+  List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl;
+  end_def ();
+  List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
+  (* type bodies *)
   let in_function = if List.length caselist = 1 then in_function else None in
   let cases =
     List.map2
-      (fun (pat, ext_env) (spat, sexp) ->
-        let exp = type_expect ?in_function ext_env sexp ty_res in
-        (pat, exp))
+      (fun (pat, (ext_env, unpacks)) (spat, sexp) ->
+        let sexp = wrap_unpacks sexp unpacks in
+        let ty_res' =
+          if !Clflags.principal then begin
+            begin_def ();
+            let ty = instance ~partial:true env ty_res in
+            end_def ();
+            generalize_structure ty; ty
+          end
+          else if contains_gadt env spat then correct_levels ty_res
+          else ty_res in
+        (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
+          Printtyp.raw_type_expr ty_res'; *)
+        let exp = type_expect ?in_function ext_env sexp ty_res' in
+        (pat, {exp with exp_type = instance env ty_res'}))
       pat_env_list caselist
   in
+  if !Clflags.principal || has_gadts then begin
+    let ty_res' = instance env ty_res in
+    List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases
+  end;
   let partial =
-    match partial_loc with
-    | None -> Partial
-    | Some partial_loc -> Parmatch.check_partial partial_loc cases
+    if partial_flag then
+      Parmatch.check_partial_gadt (partial_pred ~lev env ty_arg) loc cases
+    else
+      Partial
   in
   add_delayed_check (fun () -> Parmatch.check_unused env cases);
+  if has_gadts then begin
+    end_def ();
+    (* Ensure that existential types do not escape *)
+    unify_exp_types loc env (instance env ty_res) (newvar ()) ;
+  end;
   cases, partial
 
 (* Typing of let bindings *)
 
-and type_let env rec_flag spat_sexp_list scope =
+and type_let ?(check = fun s -> Warnings.Unused_var s)
+             ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    env rec_flag spat_sexp_list scope allow =
   begin_def();
   if !Clflags.principal then begin_def ();
-  let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in
-  let (pat_list, new_env, force) = type_pattern_list env spatl scope in
-  if rec_flag = Recursive then
+
+  let is_fake_let =
+    match spat_sexp_list with
+    | [_, {pexp_desc=Pexp_match(
+           {pexp_desc=Pexp_ident(Longident.Lident "*opt*")},_)}] ->
+        true (* the fake let-declaration introduced by fun ?(x = e) -> ... *)
+    | _ ->
+        false
+  in
+  let check = if is_fake_let then check_strict else check in
+
+  let spatl =
+    List.map
+      (fun (spat, sexp) ->
+        match spat.ppat_desc, sexp.pexp_desc with
+          (Ppat_any | Ppat_constraint _), _ -> spat
+        | _, Pexp_constraint (_, _, Some sty)
+        | _, Pexp_constraint (_, Some sty, None) when !Clflags.principal ->
+            (* propagate type annotation to pattern,
+               to allow it to be generalized in -principal mode *)
+            {ppat_desc = Ppat_constraint (spat, sty);
+             ppat_loc = {spat.ppat_loc with Location.loc_ghost=true}}
+        | _ -> spat)
+      spat_sexp_list in
+  let nvs = List.map (fun _ -> newvar ()) spatl in
+  let (pat_list, new_env, force, unpacks) =
+    type_pattern_list env spatl scope nvs allow in
+  let is_recursive = (rec_flag = Recursive) in
+  (* If recursive, first unify with an approximation of the expression *)
+  if is_recursive then
     List.iter2
       (fun pat (_, sexp) ->
         let pat =
           match pat.pat_type.desc with
           | Tpoly (ty, tl) ->
-              {pat with pat_type = snd (instance_poly false tl ty)}
+              {pat with pat_type =
+               snd (instance_poly ~keep_names:true false tl ty)}
           | _ -> pat
         in unify_pat env pat (type_approx env sexp))
       pat_list spat_sexp_list;
+  (* Polymorphic variant processing *)
+  List.iter
+    (fun pat ->
+      if has_variants pat then begin
+        Parmatch.pressure_variants env [pat];
+        iter_pattern finalize_variant pat
+      end)
+    pat_list;
+  (* Generalize the structure *)
   let pat_list =
     if !Clflags.principal then begin
       end_def ();
       List.map
         (fun pat ->
           iter_pattern (fun pat -> generalize_structure pat.pat_type) pat;
-          {pat with pat_type = instance pat.pat_type})
+          {pat with pat_type = instance env pat.pat_type})
         pat_list
     end else pat_list in
-  (* Polymoprhic variant processing *)
-  List.iter
-    (fun pat ->
-      if has_variants pat then begin
-        Parmatch.pressure_variants env [pat];
-        iter_pattern finalize_variant pat
-      end)
-    pat_list;
   (* Only bind pattern variables after generalizing *)
   List.iter (fun f -> f()) force;
   let exp_env =
-    match rec_flag with Nonrecursive | Default -> env | Recursive -> new_env in
+    if is_recursive then new_env else env in
+
+  let current_slot = ref None in
+  let warn_unused =
+    Warnings.is_active (check "") || Warnings.is_active (check_strict "") in
+  let pat_slot_list =
+    (* Algorithm to detect unused declarations in recursive bindings:
+       - During type checking of the definitions, we capture the 'value_used'
+         events on the bound identifiers and record them in a slot corresponding
+         to the current definition (!current_slot).
+         In effect, this creates a dependency graph between definitions.
+
+       - After type checking the definition (!current_slot = Mone),
+         when one of the bound identifier is effectively used, we trigger
+         again all the events recorded in the corresponding slot.
+         The effect is to traverse the transitive closure of the graph created
+         in the first step.
+
+       We also keep track of whether *all* variables in a given pattern
+       are unused. If this is the case, for local declarations, the issued
+       warning is 26, not 27.
+     *)
+    List.map
+      (fun pat ->
+        if not warn_unused then pat, None
+        else
+          let some_used = ref false in
+            (* has one of the identifier of this pattern been used? *)
+          let slot = ref [] in
+          List.iter
+            (fun id ->
+              let vd = Env.find_value (Path.Pident id) new_env in
+              (* note: Env.find_value does not trigger the value_used event *)
+              let name = Ident.name id in
+              let used = ref false in
+              if not (name = "" || name.[0] = '_' || name.[0] = '#') then
+                add_delayed_check
+                  (fun () ->
+                    if not !used then
+                      Location.prerr_warning vd.val_loc
+                        ((if !some_used then check_strict else check) name)
+                  );
+              Env.set_value_used_callback
+                name vd
+                (fun () ->
+                  match !current_slot with
+                  | Some slot -> slot := (name, vd) :: !slot
+                  | None ->
+                      List.iter
+                        (fun (name, vd) -> Env.mark_value_used name vd)
+                        (get_ref slot);
+                      used := true;
+                      some_used := true
+                )
+            )
+            (Typedtree.pat_bound_idents pat);
+          pat, Some slot
+        )
+      pat_list
+  in
   let exp_list =
     List.map2
-      (fun (spat, sexp) pat ->
+      (fun (spat, sexp) (pat, slot) ->
+        let sexp =
+          if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in
+        if is_recursive then current_slot := slot;
         match pat.pat_type.desc with
         | Tpoly (ty, tl) ->
             begin_def ();
-            let vars, ty' = instance_poly true tl ty in
+            if !Clflags.principal then begin_def ();
+            let vars, ty' = instance_poly ~keep_names:true true tl ty in
+            if !Clflags.principal then begin
+              end_def ();
+              generalize_structure ty'
+            end;
             let exp = type_expect exp_env sexp ty' in
             end_def ();
             check_univars env true "definition" exp pat.pat_type vars;
-            {exp with exp_type = instance exp.exp_type}
+            {exp with exp_type = instance env exp.exp_type}
         | _ -> type_expect exp_env sexp pat.pat_type)
-      spat_sexp_list pat_list in
+      spat_sexp_list pat_slot_list in
+  current_slot := None;
   List.iter2
     (fun pat exp -> ignore(Parmatch.check_partial pat.pat_loc [pat, exp]))
     pat_list exp_list;
@@ -2254,13 +2908,24 @@ and type_let env rec_flag spat_sexp_list scope =
   List.iter
     (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
     pat_list;
-  (List.combine pat_list exp_list, new_env)
+  (List.combine pat_list exp_list, new_env, unpacks)
 
 (* Typing of toplevel bindings *)
 
 let type_binding env rec_flag spat_sexp_list scope =
   Typetexp.reset_type_variables();
-  type_let env rec_flag spat_sexp_list scope
+  let (pat_exp_list, new_env, unpacks) =
+    type_let
+      ~check:(fun s -> Warnings.Unused_value_declaration s)
+      ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
+      env rec_flag spat_sexp_list scope false
+  in
+  (pat_exp_list, new_env)
+
+let type_let env rec_flag spat_sexp_list scope =
+  let (pat_exp_list, new_env, unpacks) =
+    type_let env rec_flag spat_sexp_list scope false in
+  (pat_exp_list, new_env)
 
 (* Typing of toplevel expressions *)
 
@@ -2271,7 +2936,12 @@ let type_expression env sexp =
   end_def();
   if is_nonexpansive exp then generalize exp.exp_type
   else generalize_expansive env exp.exp_type;
-  exp
+  match sexp.pexp_desc with
+    Pexp_ident lid ->
+      (* Special case for keeping type variables when looking-up a variable *)
+      let (path, desc) = Env.lookup_value lid env in
+      {exp with exp_type = desc.val_type}
+  | _ -> exp
 
 (* Error report *)
 
@@ -2426,3 +3096,24 @@ let report_error ppf = function
       report_unification_error ppf trace
         (fun ppf -> fprintf ppf "This %s has type" kind)
         (fun ppf -> fprintf ppf "which is less general than")
+  | Modules_not_allowed ->
+      fprintf ppf "Modules are not allowed in this pattern."
+  | Cannot_infer_signature ->
+      fprintf ppf
+        "The signature for this packaged module couldn't be inferred."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is packed module, but the expected type is@ %a"
+        type_expr ty
+  | Recursive_local_constraint trace ->
+      report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "Recursive local constraint when unifying")
+        (function ppf ->
+           fprintf ppf "with")
+  | Unexpected_existential ->
+      fprintf ppf
+        "Unexpected existential"
+
+let () =
+  Env.add_delayed_check_forward := add_delayed_check

diff --git a/typing/typecore.mli b/typing/typecore.mli
index 3fb90ff34edf37349a47fed9336bb3666ce6c50e..8b9ce86f02a8bf115edb344ab1dc08442e31976f 100644 (file)
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -51,12 +51,14 @@ val type_exp:
 val type_approx:
         Env.t -> Parsetree.expression -> type_expr
 val type_argument:
-        Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression
+        Env.t -> Parsetree.expression ->
+        type_expr -> type_expr -> Typedtree.expression
 
 val option_some: Typedtree.expression -> Typedtree.expression
 val option_none: type_expr -> Location.t -> Typedtree.expression
 val extract_option_type: Env.t -> type_expr -> type_expr
 val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit
+val generalizable: int -> type_expr -> bool
 val reset_delayed_checks: unit -> unit
 val force_delayed_checks: unit -> unit
 
@@ -96,6 +98,11 @@ type error =
   | Not_a_variant_type of Longident.t
   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
+  | Modules_not_allowed
+  | Cannot_infer_signature
+  | Not_a_packed_module of type_expr
+  | Recursive_local_constraint of (type_expr * type_expr) list
+  | Unexpected_existential
 
 exception Error of Location.t * error
 
@@ -109,5 +116,8 @@ val type_open: (Env.t -> Location.t -> Longident.t -> Env.t) ref
 val type_object:
   (Env.t -> Location.t -> Parsetree.class_structure ->
    Typedtree.class_structure * class_signature * string list) ref
+val type_package:
+  (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> type_expr list ->
+   Typedtree.module_expr * type_expr list) ref
 
 val create_package_type: Location.t -> Env.t -> Parsetree.package_type -> type_expr

diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index f8a58181515679af1587e0a267248ef1a1e8af38..cfcf55126b0640c478039e850838df30c7786a81 100644 (file)
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
 (*                                                                     *)
@@ -30,7 +30,7 @@ type error =
   | Recursive_abbrev of string
   | Definition_mismatch of type_expr * Includecore.type_mismatch list
   | Constraint_failed of type_expr * type_expr
-  | Unconsistent_constraint of (type_expr * type_expr) list
+  | Inconsistent_constraint of (type_expr * type_expr) list
   | Type_clash of (type_expr * type_expr) list
   | Parameters_differ of Path.t * type_expr * type_expr
   | Null_arity_external
@@ -42,6 +42,7 @@ type error =
   | Unavailable_type_constructor of Path.t
   | Bad_fixed_type of string
   | Unbound_type_var_exc of type_expr * type_expr
+  | Varying_anonymous
 
 exception Error of Location.t * error
 
@@ -58,6 +59,8 @@ let enter_type env (name, sdecl) id =
         begin match sdecl.ptype_manifest with None -> None
         | Some _ -> Some(Ctype.newvar ()) end;
       type_variance = List.map (fun _ -> true, true, true) sdecl.ptype_params;
+      type_newtype_level = None;
+      type_loc = sdecl.ptype_loc;
     }
   in
   Env.add_type id decl env
@@ -109,7 +112,7 @@ let set_fixed_row env loc p decl =
     | _ ->
         raise (Error (loc, Bad_fixed_type "is not an object or variant"))
   in
-  if rv.desc <> Tvar then
+  if not (Btype.is_Tvar rv) then
     raise (Error (loc, Bad_fixed_type "has no row variable"));
   rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
 
@@ -121,15 +124,21 @@ module StringSet =
     let compare = compare
   end)
 
+let make_params sdecl =
+  try 
+    List.map 
+      (function
+         None -> Ctype.new_global_var ~name:"_" ()
+       | Some x -> enter_type_variable true sdecl.ptype_loc x)
+      sdecl.ptype_params
+  with Already_bound ->
+    raise(Error(sdecl.ptype_loc, Repeated_parameter))
+
 let transl_declaration env (name, sdecl) id =
   (* Bind type parameters *)
   reset_type_variables();
   Ctype.begin_def ();
-  let params =
-    try List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
-    with Already_bound ->
-      raise(Error(sdecl.ptype_loc, Repeated_parameter))
-  in
+  let params = make_params sdecl in
   let cstrs = List.map
       (fun (sty, sty', loc) ->
         transl_simple_type env false sty,
@@ -145,19 +154,38 @@ let transl_declaration env (name, sdecl) id =
         | Ptype_variant cstrs ->
             let all_constrs = ref StringSet.empty in
             List.iter
-              (fun (name, args, loc) ->
+              (fun (name, _, _, loc) ->
                 if StringSet.mem name !all_constrs then
                   raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
                 all_constrs := StringSet.add name !all_constrs)
               cstrs;
-            if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs)
-               > (Config.max_tag + 1) then
+            if List.length
+               (List.filter (fun (_, args, _, _) -> args <> []) cstrs)
+               > (Config.max_tag + 1) then
               raise(Error(sdecl.ptype_loc, Too_many_constructors));
-            Type_variant
-              (List.map
-                 (fun (name, args, loc) ->
-                    (name, List.map (transl_simple_type env true) args))
-              cstrs)
+           let make_cstr (name, args, ret_type, loc) =
+             match ret_type with
+             | None ->
+                 (name, List.map (transl_simple_type env true) args, None)
+             | Some sty -> 
+                (* if it's a generalized constructor we must first narrow and
+                   then widen so as to not introduce any new constraints *)
+                 let z = narrow () in 
+                 reset_type_variables ();
+                 let args = List.map (transl_simple_type env false) args in 
+                 let ret_type =
+                    let ty = transl_simple_type env false sty in
+                    let p = Path.Pident id in
+                    match (Ctype.repr ty).desc with
+                      Tconstr (p', _, _) when Path.same p p' -> ty
+                    | _ -> raise(Error(sty.ptyp_loc,
+                             Constraint_failed (ty, Ctype.newconstr p params)))
+                 in
+                 widen z;
+                 (name, args, Some ret_type)
+           in
+           Type_variant (List.map make_cstr cstrs)
+           
         | Ptype_record lbls ->
             let all_labels = ref StringSet.empty in
             List.iter
@@ -187,13 +215,15 @@ let transl_declaration env (name, sdecl) id =
             Some (transl_simple_type env no_row sty)
         end;
       type_variance = List.map (fun _ -> true, true, true) params;
+      type_newtype_level = None;
+      type_loc = sdecl.ptype_loc;
     } in
 
   (* Check constraints *)
   List.iter
     (fun (ty, ty', loc) ->
       try Ctype.unify env ty ty' with Ctype.Unify tr ->
-        raise(Error(loc, Unconsistent_constraint tr)))
+        raise(Error(loc, Inconsistent_constraint tr)))
     cstrs;
   Ctype.end_def ();
   (* Add abstract row *)
@@ -219,7 +249,11 @@ let generalize_decl decl =
     Type_abstract ->
       ()
   | Type_variant v ->
-      List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
+      List.iter
+       (fun (_, tyl, ret_type) ->
+         List.iter Ctype.generalize tyl;
+         may Ctype.generalize ret_type)
+       v
   | Type_record(r, rep) ->
       List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
   end;
@@ -230,12 +264,7 @@ let generalize_decl decl =
 
 (* Check that all constraints are enforced *)
 
-module TypeSet =
-  Set.Make
-    (struct
-      type t = type_expr
-      let compare t1 t2 = t1.id - t2.id
-    end)
+module TypeSet = Btype.TypeSet
 
 let rec check_constraints_rec env loc visited ty =
   let ty = Ctype.repr ty in
@@ -270,15 +299,23 @@ let check_constraints env (_, sdecl) (_, decl) =
       in
       let pl = find_pl sdecl.ptype_kind in
       List.iter
-        (fun (name, tyl) ->
-          let styl =
-            try let (_,sty,_) = List.find (fun (n,_,_) -> n = name) pl in sty
+        (fun (name, tyl, ret_type) ->
+          let (styl, sret_type) =
+            try
+             let (_, sty, sret_type, _) =
+               List.find (fun (n,_,_,_) -> n = name)  pl
+             in (sty, sret_type)
             with Not_found -> assert false in
           List.iter2
             (fun sty ty ->
               check_constraints_rec env sty.ptyp_loc visited ty)
-            styl tyl)
-        l
+            styl tyl;
+         match sret_type, ret_type with
+         | Some sr, Some r ->
+             check_constraints_rec env sr.ptyp_loc visited r
+         | _ ->
+             () )
+       l
   | Type_record (l, _) ->
       let rec find_pl = function
           Ptype_record pl -> pl
@@ -322,8 +359,10 @@ let check_abbrev env (_, sdecl) (id, decl) =
               else if not (Ctype.equal env false args decl.type_params)
               then [Includecore.Constraint]
               else
-                Includecore.type_declarations env id
+                Includecore.type_declarations env
+                  (Path.last path)
                   decl'
+                  id
                   (Subst.type_declaration
                      (Subst.add_type id path Subst.identity) decl)
             in
@@ -364,7 +403,7 @@ let check_recursion env loc path decl to_check =
           else if to_check path' && not (List.mem path' prev_exp) then begin
             try
               (* Attempt expansion *)
-              let (params0, body0) = Env.find_type_expansion path' env in
+              let (params0, body0, _) = Env.find_type_expansion path' env in
               let (params, body) =
                 Ctype.instance_parameterized_type params0 body0 in
               begin
@@ -463,7 +502,7 @@ let compute_variance env tvl nega posi cntr ty =
           compute_same row.row_more
       | Tpoly (ty, _) ->
           compute_same ty
-      | Tvar | Tnil | Tlink _ | Tunivar -> ()
+      | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
       | Tpackage (_, _, tyl) ->
           List.iter (compute_variance_rec true true true) tyl
     end
@@ -481,7 +520,7 @@ let whole_type decl =
   match decl.type_kind with
     Type_variant tll ->
       Btype.newgenty
-        (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll))
+        (Ttuple (List.map (fun (_, tl, _) -> Btype.newgenty (Ttuple tl)) tll)) 
   | Type_record (ftl, _) ->
       Btype.newgenty
         (Ttuple (List.map (fun (_, _, ty) -> ty) ftl))
@@ -490,43 +529,23 @@ let whole_type decl =
         Some ty -> ty
       | _ -> Btype.newgenty (Ttuple [])
 
-let compute_variance_decl env check decl (required, loc) =
-  if decl.type_kind = Type_abstract && decl.type_manifest = None then
-    List.map (fun (c, n) -> if c || n then (c, n, n) else (true, true, true))
-      required
-  else
+let compute_variance_type env check (required, loc) decl tyl =
   let params = List.map Btype.repr decl.type_params in
   let tvl0 = List.map make_variance params in
-  let fvl = if check then Ctype.free_variables (whole_type decl) else [] in
+  let args = Btype.newgenty (Ttuple params) in
+  let fvl = if check then Ctype.free_variables args else [] in
   let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
   let tvl1 = List.map make_variance fvl in
   let tvl2 = List.map make_variance fvl in
   let tvl = tvl0 @ tvl1 in
-  begin match decl.type_kind with
-    Type_abstract ->
-      begin match decl.type_manifest with
-        None -> assert false
-      | Some ty -> compute_variance env tvl true false false ty
-      end
-  | Type_variant tll ->
-      List.iter
-        (fun (_,tl) ->
-          List.iter (compute_variance env tvl true false false) tl)
-        tll
-  | Type_record (ftl, _) ->
-      List.iter
-        (fun (_, mut, ty) ->
-          let cn = (mut = Mutable) in
-          compute_variance env tvl true cn cn ty)
-        ftl
-  end;
+  List.iter (fun (cn,ty) -> compute_variance env tvl true cn cn ty) tyl;
   let required =
     List.map (fun (c,n as r) -> if c || n then r else (true,true))
       required
   in
   List.iter2
     (fun (ty, co, cn, ct) (c, n) ->
-      if ty.desc <> Tvar then begin
+      if not (Btype.is_Tvar ty) then begin
         co := c; cn := n; ct := n;
         compute_variance env tvl2 c n n ty
       end)
@@ -534,10 +553,7 @@ let compute_variance_decl env check decl (required, loc) =
   List.iter2
     (fun (ty, c1, n1, t1) (_, c2, n2, t2) ->
       if !c1 && not !c2 || !n1 && not !n2
-      (* || !t1 && not !t2 && decl.type_kind = Type_abstract *)
-      then raise (Error(loc,
-                        if not (!c2 || !n2) then Unbound_type_var (ty, decl)
-                        else Bad_variance (0, (!c1,!n1), (!c2,!n2)))))
+      then raise (Error(loc, Bad_variance (0, (!c1,!n1), (!c2,!n2)))))
     tvl1 tvl2;
   let pos = ref 0 in
   List.map2
@@ -550,6 +566,65 @@ let compute_variance_decl env check decl (required, loc) =
       (!co, !cn, !ct))
     tvl0 required
 
+let add_false = List.map (fun ty -> false, ty)
+
+(* A parameter is constrained if either is is instantiated,
+   or it is a variable appearing in another parameter *)
+let constrained env vars ty =
+  let ty = Ctype.expand_head env ty in
+  match ty.desc with
+  | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars
+  | _ -> true
+
+let compute_variance_gadt env check (required, loc as rloc) decl
+    (_, tl, ret_type_opt) =
+  match ret_type_opt with
+  | None ->
+      compute_variance_type env check rloc {decl with type_private = Private}
+        (add_false tl)
+  | Some ret_type ->
+      match Ctype.repr ret_type with
+      | {desc=Tconstr (path, tyl, _)} ->
+          let fvl = List.map Ctype.free_variables tyl in
+          let _ =
+            List.fold_left2
+              (fun (fv1,fv2) ty (c,n) ->
+                match fv2 with [] -> assert false
+                | fv :: fv2 ->
+                    (* fv1 @ fv2 = free_variables of other parameters *)
+                    if (c||n) && constrained env (fv1 @ fv2) ty then
+                      raise (Error(loc, Varying_anonymous));
+                    (fv :: fv1, fv2))
+              ([], fvl) tyl required
+          in
+          compute_variance_type env check rloc
+            {decl with type_params = tyl; type_private = Private}
+            (add_false tl)
+      | _ -> assert false
+            
+let compute_variance_decl env check decl (required, loc as rloc) =
+  if decl.type_kind = Type_abstract && decl.type_manifest = None then
+    List.map (fun (c, n) -> if c || n then (c, n, n) else (true, true, true))
+      required
+  else match decl.type_kind with
+  | Type_abstract ->
+      begin match decl.type_manifest with
+        None -> assert false
+      | Some ty -> compute_variance_type env check rloc decl [false, ty]
+      end
+  | Type_variant tll ->
+      if List.for_all (fun (_,_,ret) -> ret = None) tll then
+        compute_variance_type env check rloc decl
+          (add_false (List.flatten (List.map (fun (_,tyl,_) -> tyl) tll)))
+      else begin
+        match List.map (compute_variance_gadt env check rloc decl) tll with
+        | vari :: _ -> vari
+        | _ -> assert false
+      end
+  | Type_record (ftl, _) ->
+      compute_variance_type env check rloc decl
+        (List.map (fun (_, mut, ty) -> (mut = Mutable, ty)) ftl)
+
 let is_sharp id =
   let s = Ident.name id in
   String.length s > 0 && s.[0] = '#'
@@ -612,7 +687,7 @@ let check_duplicates name_sdecl_list =
     (fun (name, sdecl) -> match sdecl.ptype_kind with
       Ptype_variant cl ->
         List.iter
-          (fun (cname, _, loc) ->
+          (fun (cname, _, _, loc) ->
             try
               let name' = Hashtbl.find constrs cname in
               Location.prerr_warning loc
@@ -676,8 +751,28 @@ let transl_type_decl env name_sdecl_list =
   (* Enter types. *)
   let temp_env = List.fold_left2 enter_type env name_sdecl_list id_list in
   (* Translate each declaration. *)
-  let decls =
-    List.map2 (transl_declaration temp_env) name_sdecl_list id_list in
+  let current_slot = ref None in
+  let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
+  let id_slots id =
+    if not warn_unused then id, None
+    else
+      (* See typecore.ml for a description of the algorithm used
+         to detect unused declarations in a set of recursive definitions. *)
+      let slot = ref [] in
+      let td = Env.find_type (Path.Pident id) temp_env in
+      let name = Ident.name id in
+      Env.set_type_used_callback
+        name td
+        (fun old_callback ->
+          match !current_slot with
+          | Some slot -> slot := (name, td) :: !slot
+          | None -> List.iter (fun (name, d) -> Env.mark_type_used name d) (get_ref slot); old_callback ()
+        );
+      id, Some slot
+  in
+  let transl_declaration name_sdecl (id, slot) = current_slot := slot; transl_declaration temp_env name_sdecl id in
+  let decls = List.map2 transl_declaration name_sdecl_list (List.map id_slots id_list) in
+  current_slot := None;
   (* Check for duplicates *)
   check_duplicates name_sdecl_list;
   (* Build the final env. *)
@@ -733,13 +828,14 @@ let transl_closed_type env sty =
   | []      -> ty
   | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty)))
 
-let transl_exception env excdecl =
+let transl_exception env loc excdecl =
   reset_type_variables();
   Ctype.begin_def();
   let types = List.map (transl_closed_type env) excdecl in
   Ctype.end_def();
   List.iter Ctype.generalize types;
-  types
+  { exn_args = types;
+    exn_loc = loc }
 
 (* Translate an exception rebinding *)
 let transl_exn_rebind env loc lid =
@@ -748,16 +844,18 @@ let transl_exn_rebind env loc lid =
       Env.lookup_constructor lid env
     with Not_found ->
       raise(Error(loc, Unbound_exception lid)) in
+  Env.mark_constructor `Positive env (Longident.last lid) cdescr;
   match cdescr.cstr_tag with
-    Cstr_exception path -> (path, cdescr.cstr_args)
+    Cstr_exception (path, _) ->
+      (path, {exn_args = cdescr.cstr_args; exn_loc = loc})
   | _ -> raise(Error(loc, Not_an_exception lid))
 
 (* Translate a value declaration *)
-let transl_value_decl env valdecl =
+let transl_value_decl env loc valdecl =
   let ty = Typetexp.transl_type_scheme env valdecl.pval_type in
   match valdecl.pval_prim with
     [] ->
-      { val_type = ty; val_kind = Val_reg }
+      { val_type = ty; val_kind = Val_reg; val_loc = loc }
   | decl ->
       let arity = Ctype.arity ty in
       if arity = 0 then
@@ -767,18 +865,14 @@ let transl_value_decl env valdecl =
       && prim.prim_arity > 5
       && prim.prim_native_name = ""
       then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
-      { val_type = ty; val_kind = Val_prim prim }
+      { val_type = ty; val_kind = Val_prim prim; val_loc = loc }
 
 (* Translate a "with" constraint -- much simplified version of
     transl_type_decl. *)
 let transl_with_constraint env id row_path orig_decl sdecl =
   reset_type_variables();
   Ctype.begin_def();
-  let params =
-    try
-      List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
-    with Already_bound ->
-      raise(Error(sdecl.ptype_loc, Repeated_parameter)) in
+  let params = make_params sdecl in
   let orig_decl = Ctype.instance_declaration orig_decl in
   let arity_ok = List.length params = orig_decl.type_arity in
   if arity_ok then
@@ -789,7 +883,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
          Ctype.unify env (transl_simple_type env false ty)
                          (transl_simple_type env false ty')
        with Ctype.Unify tr ->
-         raise(Error(loc, Unconsistent_constraint tr)))
+         raise(Error(loc, Inconsistent_constraint tr)))
     sdecl.ptype_cstrs;
   let no_row = not (is_fixed_type sdecl) in
   let decl =
@@ -804,6 +898,8 @@ let transl_with_constraint env id row_path orig_decl sdecl =
             Some(transl_simple_type env no_row sty)
         end;
       type_variance = [];
+      type_newtype_level = None;
+      type_loc = sdecl.ptype_loc;
     }
   in
   begin match row_path with None -> ()
@@ -833,7 +929,10 @@ let abstract_type_decl arity =
       type_kind = Type_abstract;
       type_private = Public;
       type_manifest = None;
-      type_variance = replicate_list (true, true, true) arity } in
+      type_variance = replicate_list (true, true, true) arity;
+      type_newtype_level = None;
+      type_loc = Location.none;
+     } in
   Ctype.end_def();
   generalize_decl decl;
   decl
@@ -912,10 +1011,10 @@ let report_error ppf = function
         (Includecore.report_type_mismatch "the original" "this" "definition")
         errs
   | Constraint_failed (ty, ty') ->
-      fprintf ppf "Constraints are not satisfied in this type.@.";
       Printtyp.reset_and_mark_loops ty;
       Printtyp.mark_loops ty';
-      fprintf ppf "@[<hv>Type@ %a@ should be an instance of@ %a@]"
+      fprintf ppf "@[%s@ @[<hv>Type@ %a@ should be an instance of@ %a@]@]"
+        "Constraints are not satisfied in this type."
         Printtyp.type_expr ty Printtyp.type_expr ty'
   | Parameters_differ (path, ty, ty') ->
       Printtyp.reset_and_mark_loops ty;
@@ -923,7 +1022,7 @@ let report_error ppf = function
       fprintf ppf
         "@[<hv>In the definition of %s, type@ %a@ should be@ %a@]"
         (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty'
-  | Unconsistent_constraint trace ->
+  | Inconsistent_constraint trace ->
       fprintf ppf "The type constraints are not consistent.@.";
       Printtyp.report_unification_error ppf trace
         (fun ppf -> fprintf ppf "Type")
@@ -944,9 +1043,10 @@ let report_error ppf = function
       fprintf ppf "A type variable is unbound in this type declaration";
       let ty = Ctype.repr ty in
       begin match decl.type_kind, decl.type_manifest with
-        Type_variant tl, _ ->
-          explain_unbound ppf ty tl (fun (_,tl) -> Btype.newgenty (Ttuple tl))
-            "case" (fun (lab,_) -> lab ^ " of ")
+      | Type_variant tl, _ ->
+          explain_unbound ppf ty tl (fun (_,tl,_) -> 
+           Btype.newgenty (Ttuple tl)) 
+            "case" (fun (lab,_,_) -> lab ^ " of ") 
       | Type_record (tl, _), _ ->
           explain_unbound ppf ty tl (fun (_,_,t) -> t)
             "field" (fun (lab,_,_) -> lab ^ ": ")
@@ -978,12 +1078,11 @@ let report_error ppf = function
         | _ -> "th"
       in
       if n < 1 then
-        fprintf ppf "%s@ %s@ %s"
-          "In this definition, a type variable"
-          "has a variance that is not reflected"
-          "by its occurrence in type parameters."
+        fprintf ppf "@[%s@ %s@]"
+          "In this definition, a type variable has a variance that"
+          "is not reflected by its occurrence in type parameters."
       else
-        fprintf ppf "%s@ %s@ %s %d%s %s %s,@ %s %s"
+        fprintf ppf "@[%s@ %s@ %s %d%s %s %s,@ %s %s@]"
           "In this definition, expected parameter"
           "variances are not satisfied."
           "The" n (suffix n)
@@ -993,3 +1092,7 @@ let report_error ppf = function
       fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
   | Bad_fixed_type r ->
       fprintf ppf "This fixed type %s" r
+  | Varying_anonymous ->
+      fprintf ppf "@[%s@ %s@ %s@]"
+        "In this GADT definition," "the variance of some parameter"
+        "cannot be checked"

diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index f0e742bd896ea4c889e9afaa9cdb0c7b3355bf9c..36b0aac62d813fa6cc415e0b20e51e45f48dfdbb 100644 (file)
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -21,13 +21,13 @@ val transl_type_decl:
     Env.t -> (string * Parsetree.type_declaration) list ->
                                   (Ident.t * type_declaration) list * Env.t
 val transl_exception:
-    Env.t -> Parsetree.exception_declaration -> exception_declaration
+    Env.t -> Location.t -> Parsetree.exception_declaration -> exception_declaration
 
 val transl_exn_rebind:
     Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
 
 val transl_value_decl:
-    Env.t -> Parsetree.value_description -> value_description
+    Env.t -> Location.t -> Parsetree.value_description -> value_description
 
 val transl_with_constraint:
     Env.t -> Ident.t -> Path.t option -> type_declaration ->
@@ -59,7 +59,7 @@ type error =
   | Recursive_abbrev of string
   | Definition_mismatch of type_expr * Includecore.type_mismatch list
   | Constraint_failed of type_expr * type_expr
-  | Unconsistent_constraint of (type_expr * type_expr) list
+  | Inconsistent_constraint of (type_expr * type_expr) list
   | Type_clash of (type_expr * type_expr) list
   | Parameters_differ of Path.t * type_expr * type_expr
   | Null_arity_external
@@ -71,6 +71,7 @@ type error =
   | Unavailable_type_constructor of Path.t
   | Bad_fixed_type of string
   | Unbound_type_var_exc of type_expr * type_expr
+  | Varying_anonymous
 
 exception Error of Location.t * error
 

diff --git a/typing/typedtree.ml b/typing/typedtree.ml
index e2b7e285e9dbd54d607846c1855fd3bb9530fa48..0feca199a3e7e8d38f0df8cc1bf7cdb99233ae57 100644 (file)
--- a/typing/typedtree.ml
+++ b/typing/typedtree.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,7 +24,7 @@ type pattern =
   { pat_desc: pattern_desc;
     pat_loc: Location.t;
     pat_type: type_expr;
-    pat_env: Env.t }
+    mutable pat_env: Env.t }
 
 and pattern_desc =
     Tpat_any
@@ -110,8 +110,6 @@ and class_field =
     Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list
   | Cf_val of string * Ident.t * expression option * bool
   | Cf_meth of string * expression
-  | Cf_let of rec_flag * (pattern * expression) list *
-              (Ident.t * expression) list
   | Cf_init of expression
 
 (* Value expressions for the module language *)

diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index eb64937cfefc60c93bb3d1390f393f7d35571cf8..0c5efa8ea848ccfeed6f97e6f161af8a8d29c69a 100644 (file)
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -23,7 +23,7 @@ type pattern =
   { pat_desc: pattern_desc;
     pat_loc: Location.t;
     pat_type: type_expr;
-    pat_env: Env.t }
+    mutable pat_env: Env.t }
 
 and pattern_desc =
     Tpat_any
@@ -112,8 +112,6 @@ and class_field =
   | Cf_val of string * Ident.t * expression option * bool
         (* None = virtual, true = override *)
   | Cf_meth of string * expression
-  | Cf_let of rec_flag * (pattern * expression) list *
-              (Ident.t * expression) list
   | Cf_init of expression
 
 (* Value expressions for the module language *)
@@ -163,6 +161,7 @@ val map_pattern_desc : (pattern -> pattern) -> pattern_desc -> pattern_desc
 
 val let_bound_idents: (pattern * expression) list -> Ident.t list
 val rev_let_bound_idents: (pattern * expression) list -> Ident.t list
+val pat_bound_idents: pattern -> Ident.t list
 
 (* Alpha conversion of patterns *)
 val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern

diff --git a/typing/typemod.ml b/typing/typemod.ml
index f1cc3f0a33183aa6035f17f6a3d27cb12b81bf34..0a3f24e282d3a7a26170ad919e7dbbb004b4b8b6 100644 (file)
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -39,6 +39,9 @@ type error =
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
   | With_need_typeconstr
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
 
 exception Error of Location.t * error
 
@@ -59,7 +62,7 @@ let extract_sig_open env loc mty =
 let type_open env loc lid =
   let (path, mty) = Typetexp.find_module env loc lid in
   let sg = extract_sig_open env loc mty in
-  Env.open_signature path sg env
+  Env.open_signature ~loc path sg env
 
 (* Record a module type *)
 let rm node =
@@ -119,7 +122,9 @@ let merge_constraint initial_env loc sg lid constr =
             type_manifest = None;
             type_variance =
               List.map (fun (c,n) -> (not n, not c, not c))
-              sdecl.ptype_variance }
+              sdecl.ptype_variance;
+            type_loc = Location.none;
+           type_newtype_level = None }
         and id_row = Ident.create (s^"#row") in
         let initial_env = Env.add_type id_row decl_row initial_env in
         let newdecl = Typedecl.transl_with_constraint
@@ -178,7 +183,8 @@ let merge_constraint initial_env loc sg lid constr =
                 List.map
                   (function {ptyp_desc=Ptyp_var s} -> s | _ -> raise Exit)
                   stl in
-              if params <> sdecl.ptype_params then raise Exit;
+              if List.map (fun x -> Some x) params <> sdecl.ptype_params
+             then raise Exit;
               lid
           | _ -> raise Exit
           with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr))
@@ -375,8 +381,8 @@ and transl_signature env sg =
     | item :: srem ->
         match item.psig_desc with
         | Psig_value(name, sdesc) ->
-            let desc = Typedecl.transl_value_decl env sdesc in
-            let (id, newenv) = Env.enter_value name desc env in
+            let desc = Typedecl.transl_value_decl env item.psig_loc sdesc in
+            let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in
             let rem = transl_sig newenv srem in
             if List.exists (Ident.equal id) (get_values rem) then rem
             else Tsig_value(id, desc) :: rem
@@ -388,7 +394,7 @@ and transl_signature env sg =
             let rem = transl_sig newenv srem in
             map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
         | Psig_exception(name, sarg) ->
-            let arg = Typedecl.transl_exception env sarg in
+            let arg = Typedecl.transl_exception env item.psig_loc sarg in
             let (id, newenv) = Env.enter_exception name arg env in
             let rem = transl_sig newenv srem in
             Tsig_exception(id, arg) :: rem
@@ -455,7 +461,7 @@ and transl_signature env sg =
                      Tsig_type(i', d', rs);
                      Tsig_type(i'', d'', rs)])
                  classes [rem])
-    in transl_sig env sg
+    in transl_sig (Env.in_signature env) sg
 
 and transl_modtype_info env sinfo =
   match sinfo with
@@ -642,6 +648,51 @@ let check_recmodule_inclusion env bindings =
     end
   in check_incl true (List.length bindings) env Subst.identity
 
+(* Helper for unpack *)
+
+let rec package_constraints env loc mty constrs =
+  if constrs = [] then mty
+  else let sg = extract_sig env loc mty in
+  let sg' =
+    List.map
+      (function
+        | Tsig_type (id, ({type_params=[]} as td), rs) when List.mem_assoc [Ident.name id] constrs ->
+            let ty = List.assoc [Ident.name id] constrs in
+            Tsig_type (id, {td with type_manifest = Some ty}, rs)
+        | Tsig_module (id, mty, rs) ->
+            let rec aux = function
+              | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> (l, t) :: aux rest
+              | _ :: rest -> aux rest
+              | [] -> []
+            in
+            Tsig_module (id, package_constraints env loc mty (aux constrs), rs)
+        | item -> item
+      )
+      sg
+  in
+  Tmty_signature sg'
+
+let modtype_of_package env loc p nl tl =
+  try match Env.find_modtype p env with
+  | Tmodtype_manifest mty when nl <> [] ->
+      package_constraints env loc mty (List.combine (List.map Longident.flatten nl) tl)
+  | _ ->
+      if nl = [] then Tmty_ident p
+      else raise(Error(loc, Signature_expected))
+  with Not_found ->
+    raise(Typetexp.Error(loc, Typetexp.Unbound_modtype (Ctype.lid_of_path p)))
+
+let wrap_constraint env arg mty =
+  let coercion =
+    try
+      Includemod.modtypes env arg.mod_type mty
+    with Includemod.Error msg ->
+      raise(Error(arg.mod_loc, Not_included msg)) in
+  { mod_desc = Tmod_constraint(arg, mty, coercion);
+    mod_type = mty;
+    mod_env = env;
+    mod_loc = arg.mod_loc }
+
 (* Type a module value expression *)
 
 let rec type_module sttn funct_body anchor env smod =
@@ -702,23 +753,35 @@ let rec type_module sttn funct_body anchor env smod =
   | Pmod_constraint(sarg, smty) ->
       let arg = type_module true funct_body anchor env sarg in
       let mty = transl_modtype env smty in
-      let coercion =
-        try
-          Includemod.modtypes env arg.mod_type mty
-        with Includemod.Error msg ->
-          raise(Error(sarg.pmod_loc, Not_included msg)) in
-      rm { mod_desc = Tmod_constraint(arg, mty, coercion);
-           mod_type = mty;
-           mod_env = env;
-           mod_loc = smod.pmod_loc }
+      rm {(wrap_constraint env arg mty) with mod_loc = smod.pmod_loc}
 
-  | Pmod_unpack (sexp, (p, l)) ->
+  | Pmod_unpack sexp ->
       if funct_body then
         raise (Error (smod.pmod_loc, Not_allowed_in_functor_body));
-      let l, mty = Typetexp.create_package_mty smod.pmod_loc env (p, l) in
-      let mty = transl_modtype env mty in
-      let exp = Typecore.type_expect env sexp
-          (Typecore.create_package_type smod.pmod_loc env (p, l)) in
+      if !Clflags.principal then Ctype.begin_def ();
+      let exp = Typecore.type_exp env sexp in
+      if !Clflags.principal then begin
+        Ctype.end_def ();
+        Ctype.generalize_structure exp.exp_type
+      end;
+      let mty =
+        match Ctype.expand_head env exp.exp_type with
+          {desc = Tpackage (p, nl, tl)} ->
+            if List.exists (fun t -> Ctype.free_variables t <> []) tl then
+              raise (Error (smod.pmod_loc,
+                            Incomplete_packed_module exp.exp_type));
+            if !Clflags.principal &&
+              not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type)
+            then
+              Location.prerr_warning smod.pmod_loc
+                (Warnings.Not_principal "this module unpacking");
+            modtype_of_package env smod.pmod_loc p nl tl
+        | {desc = Tvar _} ->
+            raise (Typecore.Error
+                     (smod.pmod_loc, Typecore.Cannot_infer_signature))
+        | _ ->
+            raise (Error (smod.pmod_loc, Not_a_packed_module exp.exp_type))
+      in
       rm { mod_desc = Tmod_unpack(exp, mty);
            mod_type = mty;
            mod_env = env;
@@ -753,14 +816,16 @@ and type_structure funct_body anchor env sstr scope =
           Typecore.type_binding env rec_flag sdefs scope in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         let bound_idents = let_bound_idents defs in
+        (* Note: Env.find_value does not trigger the value_used event. Values
+           will be marked as being used during the signature inclusion test. *)
         let make_sig_value id =
           Tsig_value(id, Env.find_value (Pident id) newenv) in
         (Tstr_value(rec_flag, defs) :: str_rem,
          map_end make_sig_value bound_idents sig_rem,
          final_env)
-    | {pstr_desc = Pstr_primitive(name, sdesc)} :: srem ->
-        let desc = Typedecl.transl_value_decl env sdesc in
-        let (id, newenv) = Env.enter_value name desc env in
+    | {pstr_desc = Pstr_primitive(name, sdesc); pstr_loc = loc} :: srem ->
+        let desc = Typedecl.transl_value_decl env loc sdesc in
+        let (id, newenv) = Env.enter_value ~check:(fun s -> Warnings.Unused_value_declaration s) name desc env in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_primitive(id, desc) :: str_rem,
          Tsig_value(id, desc) :: sig_rem,
@@ -776,8 +841,8 @@ and type_structure funct_body anchor env sstr scope =
         (Tstr_type decls :: str_rem,
          map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
          final_env)
-    | {pstr_desc = Pstr_exception(name, sarg)} :: srem ->
-        let arg = Typedecl.transl_exception env sarg in
+    | {pstr_desc = Pstr_exception(name, sarg); pstr_loc = loc} :: srem ->
+        let arg = Typedecl.transl_exception env loc sarg in
         let (id, newenv) = Env.enter_exception name arg env in
         let (str_rem, sig_rem, final_env) = type_struct newenv srem in
         (Tstr_exception(id, arg) :: str_rem,
@@ -964,12 +1029,56 @@ let type_module_type_of env smod =
     raise(Error(smod.pmod_loc, Non_generalizable_module mty));
   mty
 
+(* For Typecore *)
+
+let rec get_manifest_types = function
+    [] -> []
+  | Tsig_type (id, {type_params=[]; type_manifest=Some ty}, _) :: rem ->
+      (Ident.name id, ty) :: get_manifest_types rem
+  | _ :: rem -> get_manifest_types rem
+
+let type_package env m p nl tl =
+  (* Same as Pexp_letmodule *)
+  (* remember original level *)
+  let lv = Ctype.get_current_level () in
+  Ctype.begin_def ();
+  Ident.set_current_time lv;
+  let context = Typetexp.narrow () in
+  let modl = type_module env m in
+  Ctype.init_def(Ident.current_time());
+  Typetexp.widen context;
+  let (mp, env) =
+    match modl.mod_desc with
+      Tmod_ident mp -> (mp, env)
+    | _ ->
+      let (id, new_env) = Env.enter_module "%M" modl.mod_type env in
+      (Pident id, new_env)
+  in
+  let rec mkpath mp = function
+    | Lident name -> Pdot(mp, name, nopos)
+    | Ldot (m, name) -> Pdot(mkpath mp m, name, nopos)
+    | _ -> assert false
+  in
+  let tl' =
+    List.map (fun name -> Ctype.newconstr (mkpath mp name) []) nl in
+  (* go back to original level *)
+  Ctype.end_def ();
+  if nl = [] then (wrap_constraint env modl (Tmty_ident p), []) else
+  let mty = modtype_of_package env modl.mod_loc p nl tl' in
+  List.iter2
+    (fun n ty ->
+      try Ctype.unify env ty (Ctype.newvar ())
+      with Ctype.Unify _ -> raise (Error(m.pmod_loc, Scoping_pack (n,ty))))
+    nl tl';
+  (wrap_constraint env modl mty, tl')
+
 (* Fill in the forward declarations *)
 let () =
   Typecore.type_module := type_module;
   Typetexp.transl_modtype_longident := transl_modtype_longident;
   Typetexp.transl_modtype := transl_modtype;
   Typecore.type_open := type_open;
+  Typecore.type_package := type_package;
   type_module_type_of_fwd := type_module_type_of
 
 (* Typecheck an implementation file *)
@@ -978,7 +1087,6 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
   Typecore.reset_delayed_checks ();
   let (str, sg, finalenv) = type_structure initial_env ast Location.none in
   let simple_sg = simplify_signature sg in
-  Typecore.force_delayed_checks ();
   if !Clflags.print_types then begin
     fprintf std_formatter "%a@." Printtyp.signature simple_sg;
     (str, Tcoerce_none)   (* result is ignored by Compile.implementation *)
@@ -993,6 +1101,10 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           raise(Error(Location.none, Interface_not_compiled sourceintf)) in
       let dclsig = Env.read_signature modulename intf_file in
       let coercion = Includemod.compunit sourcefile sg intf_file dclsig in
+      Typecore.force_delayed_checks ();
+      (* It is important to run these checks after the inclusion test above,
+         so that value declarations which are not used internally but exported
+         are not reported as being unused. *)
       (str, coercion)
     end else begin
       check_nongen_schemes finalenv str;
@@ -1000,6 +1112,11 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       let coercion =
         Includemod.compunit sourcefile sg
                             "(inferred signature)" simple_sg in
+      Typecore.force_delayed_checks ();
+      (* See comment above. Here the target signature contains all
+         the value being exported. We can still capture unused
+         declarations like "let x = true;; let x = 1;;", because in this
+         case, the inferred signature contains only the last declaration. *)
       if not !Clflags.dont_write_files then
         Env.save_signature simple_sg modulename (outputprefix ^ ".cmi");
       (str, coercion)
@@ -1106,14 +1223,29 @@ let report_error ppf = function
            contains type variables that cannot be generalized@]" modtype mty
   | Implementation_is_required intf_name ->
       fprintf ppf
-        "@[The interface %s@ declares values, not just types.@ \
-           An implementation must be provided.@]" intf_name
+        "@[The interface %a@ declares values, not just types.@ \
+           An implementation must be provided.@]"
+        Location.print_filename intf_name
   | Interface_not_compiled intf_name ->
       fprintf ppf
-        "@[Could not find the .cmi file for interface@ %s.@]" intf_name
+        "@[Could not find the .cmi file for interface@ %a.@]"
+        Location.print_filename intf_name
   | Not_allowed_in_functor_body ->
       fprintf ppf
         "This kind of expression is not allowed within the body of a functor."
   | With_need_typeconstr ->
       fprintf ppf
         "Only type constructors with identical parameters can be substituted."
+  | Not_a_packed_module ty ->
+      fprintf ppf
+        "This expression is not a packed module. It has type@ %a"
+        type_expr ty
+  | Incomplete_packed_module ty ->
+      fprintf ppf
+        "The type of this packed module contains variables:@ %a"
+        type_expr ty
+  | Scoping_pack (lid, ty) ->
+      fprintf ppf
+        "The type %a in this module cannot be exported.@ " longident lid;
+      fprintf ppf
+        "Its type contains local dependencies:@ %a" type_expr ty

diff --git a/typing/typemod.mli b/typing/typemod.mli
index d508a429c76240f51dbc5e8fce39e69add8aafa0..a2c03aaa83a4fcf33dafab3055e7152c80f9ce5a 100644 (file)
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -51,6 +51,9 @@ type error =
   | Interface_not_compiled of string
   | Not_allowed_in_functor_body
   | With_need_typeconstr
+  | Not_a_packed_module of type_expr
+  | Incomplete_packed_module of type_expr
+  | Scoping_pack of Longident.t * type_expr
 
 exception Error of Location.t * error
 

diff --git a/typing/types.ml b/typing/types.ml
index 5996719d4d2ff9c32c8a51a86976804af4a7b82a..982dd76abdcfb11278989670387e1f8fa6a2a229 100644 (file)
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -25,7 +25,7 @@ type type_expr =
     mutable id: int }
 
 and type_desc =
-    Tvar
+    Tvar of string option
   | Tarrow of label * type_expr * type_expr * commutable
   | Ttuple of type_expr list
   | Tconstr of Path.t * type_expr list * abbrev_memo ref
@@ -35,9 +35,9 @@ and type_desc =
   | Tlink of type_expr
   | Tsubst of type_expr         (* for copying *)
   | Tvariant of row_desc
-  | Tunivar
+  | Tunivar of string option
   | Tpoly of type_expr * type_expr list
-  | Tpackage of Path.t * string list * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
 
 and row_desc =
     { row_fields: (label * row_field) list;
@@ -87,7 +87,9 @@ module Vars = Meths
 
 type value_description =
   { val_type: type_expr;                (* Type of the value *)
-    val_kind: value_kind }
+    val_kind: value_kind;
+    val_loc: Location.t;
+ }
 
 and value_kind =
     Val_reg                             (* Regular value *)
@@ -106,17 +108,20 @@ and value_kind =
 
 type constructor_description =
   { cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
     cstr_args: type_expr list;          (* Type of the arguments *)
     cstr_arity: int;                    (* Number of arguments *)
     cstr_tag: constructor_tag;          (* Tag for heap blocks *)
     cstr_consts: int;                   (* Number of constant constructors *)
     cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
     cstr_private: private_flag }        (* Read-only constructor? *)
 
 and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
-  | Cstr_exception of Path.t            (* Exception constructor *)
+  | Cstr_exception of Path.t * Location.t (* Exception constructor *)
 
 (* Record label descriptions *)
 
@@ -142,16 +147,20 @@ type type_declaration =
     type_kind: type_kind;
     type_private: private_flag;
     type_manifest: type_expr option;
-    type_variance: (bool * bool * bool) list }
-            (* covariant, contravariant, weakly contravariant *)
+    type_variance: (bool * bool * bool) list;
+    (* covariant, contravariant, weakly contravariant *)
+    type_newtype_level: (int * int) option;
+    type_loc: Location.t }
 
 and type_kind =
     Type_abstract
-  | Type_variant of (string * type_expr list) list
   | Type_record of
       (string * mutable_flag * type_expr) list * record_representation
+  | Type_variant of (string * type_expr list * type_expr option) list 
 
-type exception_declaration = type_expr list
+type exception_declaration =
+    { exn_args: type_expr list;
+      exn_loc: Location.t }
 
 (* Type expressions for the class language *)
 

diff --git a/typing/types.mli b/typing/types.mli
index a4c640845703d3cc48fa0daa70d9b6f82d7fb5c6..cf897bd7a47229995b310025537c60baad3ae3b8 100644 (file)
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -24,7 +24,7 @@ type type_expr =
     mutable id: int }
 
 and type_desc =
-    Tvar
+    Tvar of string option
   | Tarrow of label * type_expr * type_expr * commutable
   | Ttuple of type_expr list
   | Tconstr of Path.t * type_expr list * abbrev_memo ref
@@ -34,9 +34,9 @@ and type_desc =
   | Tlink of type_expr
   | Tsubst of type_expr         (* for copying *)
   | Tvariant of row_desc
-  | Tunivar
+  | Tunivar of string option
   | Tpoly of type_expr * type_expr list
-  | Tpackage of Path.t * string list * type_expr list
+  | Tpackage of Path.t * Longident.t list * type_expr list
 
 and row_desc =
     { row_fields: (label * row_field) list;
@@ -85,7 +85,9 @@ module Vars  : Map.S with type key = string
 
 type value_description =
   { val_type: type_expr;                (* Type of the value *)
-    val_kind: value_kind }
+    val_kind: value_kind;
+    val_loc: Location.t;
+   }
 
 and value_kind =
     Val_reg                             (* Regular value *)
@@ -103,17 +105,20 @@ and value_kind =
 
 type constructor_description =
   { cstr_res: type_expr;                (* Type of the result *)
+    cstr_existentials: type_expr list;  (* list of existentials *)
     cstr_args: type_expr list;          (* Type of the arguments *)
     cstr_arity: int;                    (* Number of arguments *)
     cstr_tag: constructor_tag;          (* Tag for heap blocks *)
-    cstr_consts: int;                   (* Number of constant constructors *)
+    cstr_consts: int;                   (* Number of constant constructors *) 
     cstr_nonconsts: int;                (* Number of non-const constructors *)
+    cstr_normal: int;                   (* Number of non generalized constrs *)
+    cstr_generalized: bool;             (* Constrained return type? *)
     cstr_private: private_flag }        (* Read-only constructor? *)
 
 and constructor_tag =
     Cstr_constant of int                (* Constant constructor (an int) *)
   | Cstr_block of int                   (* Regular constructor (a block) *)
-  | Cstr_exception of Path.t            (* Exception constructor *)
+  | Cstr_exception of Path.t * Location.t (* Exception constructor *)
 
 (* Record label descriptions *)
 
@@ -139,16 +144,21 @@ type type_declaration =
     type_kind: type_kind;
     type_private: private_flag;
     type_manifest: type_expr option;
-    type_variance: (bool * bool * bool) list }
-            (* covariant, contravariant, weakly contravariant *)
+    type_variance: (bool * bool * bool) list;
+    (* covariant, contravariant, weakly contravariant *)
+    type_newtype_level: (int * int) option;
+    (* definition level * expansion level *)
+    type_loc: Location.t }
 
 and type_kind =
     Type_abstract
-  | Type_variant of (string * type_expr list) list
   | Type_record of
       (string * mutable_flag * type_expr) list * record_representation
+  | Type_variant of (string * type_expr list * type_expr option) list
 
-type exception_declaration = type_expr list
+type exception_declaration =
+    { exn_args: type_expr list;
+      exn_loc: Location.t }
 
 (* Type expressions for the class language *)
 

diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 838719b7c493e6327cb067ccafdb8f18c7b5abe1..131b12a793d9f779a88c5453a9781cb5da2fc36f 100644 (file)
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -38,7 +38,7 @@ type error =
   | Variant_tags of string * string
   | Invalid_variable_name of string
   | Cannot_quantify of string * type_expr
-  | Multiple_constraints_on_type of string
+  | Multiple_constraints_on_type of Longident.t
   | Repeated_method_label of string
   | Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
@@ -53,12 +53,18 @@ exception Error of Location.t * error
 
 type variable_context = int * (string, type_expr) Tbl.t
 
+(* Local definitions *)
+
+let instance_list = Ctype.instance_list Env.empty
+
 (* Narrowing unbound identifier errors. *)
 
 let rec narrow_unbound_lid_error env loc lid make_error =
   let check_module mlid =
     try ignore (Env.lookup_module mlid env)
-    with Not_found -> narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid); assert false
+    with Not_found ->
+      narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid);
+      assert false
   in
   begin match lid with
   | Longident.Lident _ -> ()
@@ -73,28 +79,30 @@ let rec narrow_unbound_lid_error env loc lid make_error =
 let find_component lookup make_error env loc lid =
   try
     match lid with
-    | Longident.Ldot (Longident.Lident "*predef*", s) -> lookup (Longident.Lident s) Env.initial
+    | Longident.Ldot (Longident.Lident "*predef*", s) ->
+        lookup (Longident.Lident s) Env.initial
     | _ -> lookup lid env
   with Not_found ->
     (narrow_unbound_lid_error env loc lid make_error
      : unit (* to avoid a warning *));
     assert false
 
-let find_type = find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
-
-let find_constructor = find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
-
-let find_label = find_component Env.lookup_label (fun lid -> Unbound_label lid)
-
-let find_class = find_component Env.lookup_class (fun lid -> Unbound_class lid)
-
-let find_value = find_component Env.lookup_value (fun lid -> Unbound_value lid)
-
-let find_module = find_component Env.lookup_module (fun lid -> Unbound_module lid)
-
-let find_modtype = find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid)
-
-let find_cltype = find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
+let find_type =
+  find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid)
+let find_constructor =
+  find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid)
+let find_label =
+  find_component Env.lookup_label (fun lid -> Unbound_label lid)
+let find_class =
+  find_component Env.lookup_class (fun lid -> Unbound_class lid)
+let find_value =
+  find_component Env.lookup_value (fun lid -> Unbound_value lid)
+let find_module =
+  find_component Env.lookup_module (fun lid -> Unbound_module lid)
+let find_modtype =
+  find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid)
+let find_cltype =
+  find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid)
 
 (* Support for first-class modules. *)
 
@@ -119,7 +127,8 @@ let create_package_mty fake loc env (p, l) =
                ptype_manifest = if fake then None else Some t;
                ptype_variance = [];
                ptype_loc = loc} in
-      {pmty_desc=Pmty_with (mty, [ Longident.Lident s, Pwith_type d ]); pmty_loc=loc}
+      {pmty_desc=Pmty_with (mty, [ s, Pwith_type d ]);
+       pmty_loc=loc}
     )
     {pmty_desc=Pmty_ident p; pmty_loc=loc}
     l
@@ -142,6 +151,18 @@ let widen (gl, tv) =
   restore_global_level gl;
   type_variables := tv
 
+let strict_lowercase c = (c = '_' || c >= 'a' && c <= 'z')
+
+let validate_name = function
+    None -> None
+  | Some name as s ->
+      if name <> "" && strict_lowercase name.[0] then s else None
+
+let new_global_var ?name () =
+  new_global_var ?name:(validate_name name) ()
+let newvar ?name () =
+  newvar ?name:(validate_name name) ()
+
 let enter_type_variable strict loc name =
   try
     if name <> "" && name.[0] = '_' then
@@ -150,7 +171,7 @@ let enter_type_variable strict loc name =
     if strict then raise Already_bound;
     v
   with Not_found ->
-    let v = new_global_var() in
+    let v = new_global_var ~name () in
     type_variables := Tbl.add name v !type_variables;
     v
 
@@ -165,8 +186,8 @@ let wrap_method ty =
     Tpoly _ -> ty
   | _ -> Ctype.newty (Tpoly (ty, []))
 
-let new_pre_univar () =
-  let v = newvar () in pre_univars := v :: !pre_univars; v
+let new_pre_univar ?name () =
+  let v = newvar ?name () in pre_univars := v :: !pre_univars; v
 
 let rec swap_list = function
     x :: y :: l -> y :: x :: swap_list l
@@ -185,12 +206,13 @@ let rec transl_type env policy styp =
       if name <> "" && name.[0] = '_' then
         raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
       begin try
-        instance (List.assoc name !univars)
+        instance env (List.assoc name !univars)
       with Not_found -> try
-        instance (fst(Tbl.find name !used_variables))
+        instance env (fst(Tbl.find name !used_variables))
       with Not_found ->
         let v =
-          if policy = Univars then new_pre_univar () else newvar () in
+          if policy = Univars then new_pre_univar ~name () else newvar ~name ()
+        in
         used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables;
         v
       end
@@ -206,7 +228,7 @@ let rec transl_type env policy styp =
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
       let args = List.map (transl_type env policy) stl in
-      let params = Ctype.instance_list decl.type_params in
+      let params = instance_list decl.type_params in
       let unify_param =
         match decl.type_manifest with
           None -> unify_var
@@ -260,7 +282,7 @@ let rec transl_type env policy styp =
         raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                        List.length stl)));
       let args = List.map (transl_type env policy) stl in
-      let params = Ctype.instance_list decl.type_params in
+      let params = instance_list decl.type_params in
       List.iter2
         (fun (sty, ty) ty' ->
            try unify_var env ty' ty with Unify trace ->
@@ -295,7 +317,8 @@ let rec transl_type env policy styp =
                       row_fixed = false; row_more = newvar () } in
           let static = Btype.static_row row in
           let row =
-            if static || policy <> Univars then row
+            if static then { row with row_more = newty Tnil }
+            else if policy <> Univars then row
             else { row with row_more = new_pre_univar () }
           in
           newty (Tvariant row)
@@ -312,7 +335,7 @@ let rec transl_type env policy styp =
           let t =
             try List.assoc alias !univars
             with Not_found ->
-              instance (fst(Tbl.find alias !used_variables))
+              instance env (fst(Tbl.find alias !used_variables))
           in
           let ty = transl_type env policy st in
           begin try unify_var env t ty with Unify trace ->
@@ -333,7 +356,14 @@ let rec transl_type env policy styp =
             end_def ();
             generalize_structure t;
           end;
-          instance t
+          let t = instance env t in
+          let px = Btype.proxy t in
+          begin match px.desc with
+          | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
+          | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias)
+          | _ -> ()
+          end;
+          t
       end
   | Ptyp_variant(fields, closed, present) ->
       let name = ref None in
@@ -388,7 +418,7 @@ let rec transl_type env policy styp =
               {desc=Tvariant row}, _ when Btype.static_row row ->
                 let row = Btype.row_repr row in
                 row.row_fields
-            | {desc=Tvar}, Some(p, _) ->
+            | {desc=Tvar _}, Some(p, _) ->
                 raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p))
             | _ ->
                 raise(Error(sty.ptyp_loc, Not_a_variant ty))
@@ -425,13 +455,14 @@ let rec transl_type env policy styp =
           row_fixed = false; row_name = !name } in
       let static = Btype.static_row row in
       let row =
-        if static || policy <> Univars then row
+        if static then { row with row_more = newty Tnil }
+        else if policy <> Univars then row
         else { row with row_more = new_pre_univar () }
       in
       newty (Tvariant row)
   | Ptyp_poly(vars, st) ->
       begin_def();
-      let new_univars = List.map (fun name -> name, newvar()) vars in
+      let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
       let old_univars = !univars in
       univars := new_univars @ !univars;
       let ty = transl_type env policy st in
@@ -443,10 +474,12 @@ let rec transl_type env policy styp =
           (fun tyl (name, ty1) ->
             let v = Btype.proxy ty1 in
             if deep_occur v ty then begin
-              if v.level <> Btype.generic_level || v.desc <> Tvar then
-                raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)));
-              v.desc <- Tunivar;
-              v :: tyl
+              match v.desc with
+                Tvar name when v.level = Btype.generic_level ->
+                  v.desc <- Tunivar name;
+                  v :: tyl
+              | _ ->
+                raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)))
             end else tyl)
           [] new_univars
       in
@@ -483,7 +516,7 @@ let rec make_fixed_univars ty =
     match ty.desc with
     | Tvariant row ->
         let row = Btype.row_repr row in
-        if (Btype.row_more row).desc = Tunivar then
+        if Btype.is_Tunivar (Btype.row_more row) then
           ty.desc <- Tvariant
               {row with row_fixed=true;
                row_fields = List.map
@@ -512,7 +545,7 @@ let globalize_used_variables env fixed =
       then try
         r := (loc, v,  Tbl.find name !type_variables) :: !r
       with Not_found ->
-        if fixed && (repr ty).desc = Tvar then
+        if fixed && Btype.is_Tvar (repr ty) then
           raise(Error(loc, Unbound_type_variable ("'"^name)));
         let v2 = new_global_var () in
         r := (loc, v, v2) :: !r;
@@ -552,12 +585,14 @@ let transl_simple_type_univars env styp =
     List.fold_left
       (fun acc v ->
         let v = repr v in
-        if v.level <> Btype.generic_level || v.desc <> Tvar then acc
-        else (v.desc <- Tunivar ; v :: acc))
+        match v.desc with
+          Tvar name when v.level = Btype.generic_level ->
+            v.desc <- Tunivar name; v :: acc
+        | _ -> acc)
       [] !pre_univars
   in
   make_fixed_univars typ;
-  instance (Btype.newgenty (Tpoly (typ, univs)))
+  instance env (Btype.newgenty (Tpoly (typ, univs)))
 
 let transl_simple_type_delayed env styp =
   univars := []; used_variables := Tbl.empty;
@@ -629,17 +664,19 @@ let report_error ppf = function
         Printtyp.type_expr ty
   | Variant_tags (lab1, lab2) ->
       fprintf ppf
-        "Variant tags `%s@ and `%s have the same hash value.@ Change one of them."
-        lab1 lab2
+        "@[Variant tags `%s@ and `%s have the same hash value.@ %s@]"
+        lab1 lab2 "Change one of them."
   | Invalid_variable_name name ->
       fprintf ppf "The type variable name %s is not allowed in programs" name
   | Cannot_quantify (name, v) ->
-      fprintf ppf "This type scheme cannot quantify '%s :@ %s." name
-        (if v.desc = Tvar then "it escapes this scope" else
-         if v.desc = Tunivar then "it is aliased to another variable"
+      fprintf ppf
+        "@[<hov>The universal type variable '%s cannot be generalized:@ %s.@]"
+        name
+        (if Btype.is_Tvar v then "it escapes its scope" else
+         if Btype.is_Tunivar v then "it is already bound to another variable"
          else "it is not a variable")
   | Multiple_constraints_on_type s ->
-      fprintf ppf "Multiple constraints for type %s" s
+      fprintf ppf "Multiple constraints for type %a" longident s
   | Repeated_method_label s ->
       fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]"
         s "Multiple occurences are not allowed."

diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index ec9042ce8da6e3fd072f83f07306c869d33d092b..79082d5f5e2a31b4285b09151885456eb14df069 100644 (file)
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -53,7 +53,7 @@ type error =
   | Variant_tags of string * string
   | Invalid_variable_name of string
   | Cannot_quantify of string * Types.type_expr
-  | Multiple_constraints_on_type of string
+  | Multiple_constraints_on_type of Longident.t
   | Repeated_method_label of string
   | Unbound_value of Longident.t
   | Unbound_constructor of Longident.t
@@ -71,7 +71,7 @@ val report_error: formatter -> error -> unit
 (* Support for first-class modules. *)
 val transl_modtype_longident: (Location.t -> Env.t -> Longident.t -> Path.t) ref  (* from Typemod *)
 val transl_modtype: (Env.t -> Parsetree.module_type -> Types.module_type) ref (* from Typemod *)
-val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (string * Parsetree.core_type) list * Parsetree.module_type
+val create_package_mty: Location.t -> Env.t -> Parsetree.package_type -> (Longident.t * Parsetree.core_type) list * Parsetree.module_type
 
 val find_type: Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration
 val find_constructor: Env.t -> Location.t -> Longident.t -> Types.constructor_description

diff --git a/typing/unused_var.ml b/typing/unused_var.ml
deleted file mode 100644 (file)
index c90b6e8..0000000
--- a/typing/unused_var.ml
+++ /dev/null
@@ -1,267 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*           Damien Doligez, projet Cristal, INRIA Rocquencourt        *)
-(*                                                                     *)
-(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Parsetree
-
-let silent v = String.length v > 0 && v.[0] = '_';;
-
-let add_vars tbl (vll1, vll2) =
-  let add_var (v, _loc, used) = Hashtbl.add tbl v used in
-  List.iter add_var vll1;
-  List.iter add_var vll2;
-;;
-
-let rm_vars tbl (vll1, vll2) =
-  let rm_var (v, _, _) = Hashtbl.remove tbl v in
-  List.iter rm_var vll1;
-  List.iter rm_var vll2;
-;;
-
-let w_suspicious x = Warnings.Unused_var x;;
-let w_strict x = Warnings.Unused_var_strict x;;
-
-let check_rm_vars ppf tbl (vlul_pat, vlul_as) =
-  let check_rm_var kind (v, loc, used) =
-    if not !used && not (silent v)
-    then Location.print_warning loc ppf (kind v);
-    Hashtbl.remove tbl v;
-  in
-  List.iter (check_rm_var w_strict) vlul_pat;
-  List.iter (check_rm_var w_suspicious) vlul_as;
-;;
-
-let check_rm_let ppf tbl vlulpl =
-  let check_rm_one flag (v, loc, used) =
-    Hashtbl.remove tbl v;
-    flag && (silent v || not !used)
-  in
-  let warn_var w_kind (v, loc, used) =
-    if not (silent v) && not !used
-    then Location.print_warning loc ppf (w_kind v)
-  in
-  let check_rm_pat (def, def_as) =
-    let def_unused = List.fold_left check_rm_one true def in
-    let all_unused = List.fold_left check_rm_one def_unused def_as in
-    List.iter (warn_var (if all_unused then w_suspicious else w_strict)) def;
-    List.iter (warn_var w_suspicious) def_as;
-  in
-  List.iter check_rm_pat vlulpl;
-;;
-
-let rec get_vars ((vacc, asacc) as acc) p =
-  match p.ppat_desc with
-  | Ppat_any -> acc
-  | Ppat_var v -> ((v, p.ppat_loc, ref false) :: vacc, asacc)
-  | Ppat_alias (pp, v) ->
-      get_vars (vacc, ((v, p.ppat_loc, ref false) :: asacc)) pp
-  | Ppat_constant _ -> acc
-  | Ppat_tuple pl -> List.fold_left get_vars acc pl
-  | Ppat_construct (_, po, _) -> get_vars_option acc po
-  | Ppat_variant (_, po) -> get_vars_option acc po
-  | Ppat_record (ipl, cls) ->
-      List.fold_left (fun a (_, p) -> get_vars a p) acc ipl
-  | Ppat_array pl -> List.fold_left get_vars acc pl
-  | Ppat_or (p1, _p2) -> get_vars acc p1
-  | Ppat_lazy p -> get_vars acc p
-  | Ppat_constraint (pp, _) -> get_vars acc pp
-  | Ppat_type _ -> acc
-
-and get_vars_option acc po =
-  match po with
-  | Some p -> get_vars acc p
-  | None -> acc
-;;
-
-let get_pel_vars pel =
-  List.map (fun (p, _) -> get_vars ([], []) p) pel
-;;
-
-let rec structure ppf tbl l =
-  List.iter (structure_item ppf tbl) l
-
-and structure_item ppf tbl s =
-  match s.pstr_desc with
-  | Pstr_eval e -> expression ppf tbl e;
-  | Pstr_value (recflag, pel) -> let_pel ppf tbl recflag pel None;
-  | Pstr_primitive _ -> ()
-  | Pstr_type _ -> ()
-  | Pstr_exception _ -> ()
-  | Pstr_exn_rebind _ -> ()
-  | Pstr_module (_, me) -> module_expr ppf tbl me;
-  | Pstr_recmodule stml ->
-      List.iter (fun (_, _, me) -> module_expr ppf tbl me) stml;
-  | Pstr_modtype _ -> ()
-  | Pstr_open _ -> ()
-  | Pstr_class cdl -> List.iter (class_declaration ppf tbl) cdl;
-  | Pstr_class_type _ -> ()
-  | Pstr_include me -> module_expr ppf tbl me;
-
-and expression ppf tbl e =
-  match e.pexp_desc with
-  | Pexp_ident (Longident.Lident id) ->
-      begin try (Hashtbl.find tbl id) := true;
-      with Not_found -> ()
-      end;
-  | Pexp_ident _ -> ()
-  | Pexp_constant _ -> ()
-  | Pexp_let (recflag, pel, e) ->
-      let_pel ppf tbl recflag pel (Some (fun ppf tbl -> expression ppf tbl e));
-  | Pexp_function (_, eo, pel) ->
-      expression_option ppf tbl eo;
-      match_pel ppf tbl pel;
-  | Pexp_apply (e, lel) ->
-      expression ppf tbl e;
-      List.iter (fun (_, e) -> expression ppf tbl e) lel;
-  | Pexp_match (e, pel) ->
-      expression ppf tbl e;
-      match_pel ppf tbl pel;
-  | Pexp_try (e, pel) ->
-      expression ppf tbl e;
-      match_pel ppf tbl pel;
-  | Pexp_tuple el -> List.iter (expression ppf tbl) el;
-  | Pexp_construct (_, eo, _) -> expression_option ppf tbl eo;
-  | Pexp_variant (_, eo) -> expression_option ppf tbl eo;
-  | Pexp_record (iel, eo) ->
-      List.iter (fun (_, e) -> expression ppf tbl e) iel;
-      expression_option ppf tbl eo;
-  | Pexp_field (e, _) -> expression ppf tbl e;
-  | Pexp_setfield (e1, _, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_array el -> List.iter (expression ppf tbl) el;
-  | Pexp_ifthenelse (e1, e2, eo) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-      expression_option ppf tbl eo;
-  | Pexp_sequence (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_while (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_for (id, e1, e2, _, e3) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-      let defined = ([ (id, e.pexp_loc, ref true) ], []) in
-      add_vars tbl defined;
-      expression ppf tbl e3;
-      check_rm_vars ppf tbl defined;
-  | Pexp_constraint (e, _, _) -> expression ppf tbl e;
-  | Pexp_when (e1, e2) ->
-      expression ppf tbl e1;
-      expression ppf tbl e2;
-  | Pexp_send (e, _) -> expression ppf tbl e;
-  | Pexp_new _ -> ()
-  | Pexp_setinstvar (_, e) -> expression ppf tbl e;
-  | Pexp_override sel -> List.iter (fun (_, e) -> expression ppf tbl e) sel;
-  | Pexp_letmodule (_, me, e) ->
-      module_expr ppf tbl me;
-      expression ppf tbl e;
-  | Pexp_assert e -> expression ppf tbl e;
-  | Pexp_assertfalse -> ()
-  | Pexp_lazy e -> expression ppf tbl e;
-  | Pexp_poly (e, _) -> expression ppf tbl e;
-  | Pexp_object cs -> class_structure ppf tbl cs;
-  | Pexp_newtype (_, e) -> expression ppf tbl e
-  | Pexp_pack (me, _) -> module_expr ppf tbl me
-  | Pexp_open (_, e) -> expression ppf tbl e
-
-and expression_option ppf tbl eo =
-  match eo with
-  | Some e -> expression ppf tbl e;
-  | None -> ()
-
-and let_pel ppf tbl recflag pel body =
-  match recflag with
-  | Asttypes.Recursive ->
-      let defined = get_pel_vars pel in
-      List.iter (add_vars tbl) defined;
-      List.iter (fun (_, e) -> expression ppf tbl e) pel;
-      begin match body with
-      | None ->
-          List.iter (rm_vars tbl) defined;
-      | Some f ->
-          f ppf tbl;
-          check_rm_let ppf tbl defined;
-      end;
-  | _ ->
-      List.iter (fun (_, e) -> expression ppf tbl e) pel;
-      begin match body with
-      | None -> ()
-      | Some f ->
-          let defined = get_pel_vars pel in
-          List.iter (add_vars tbl) defined;
-          f ppf tbl;
-          check_rm_let ppf tbl defined;
-      end;
-
-and match_pel ppf tbl pel =
-  List.iter (match_pe ppf tbl) pel
-
-and match_pe ppf tbl (p, e) =
- let defined = get_vars ([], []) p in
-  add_vars tbl defined;
-  expression ppf tbl e;
-  check_rm_vars ppf tbl defined;
-
-and module_expr ppf tbl me =
-  match me.pmod_desc with
-  | Pmod_ident _ -> ()
-  | Pmod_structure s -> structure ppf tbl s
-  | Pmod_functor (_, _, me) -> module_expr ppf tbl me
-  | Pmod_apply (me1, me2) ->
-      module_expr ppf tbl me1;
-      module_expr ppf tbl me2;
-  | Pmod_constraint (me, _) -> module_expr ppf tbl me
-  | Pmod_unpack (e, _) -> expression ppf tbl e
-
-and class_declaration ppf tbl cd = class_expr ppf tbl cd.pci_expr
-
-and class_expr ppf tbl ce =
-  match ce.pcl_desc with
-  | Pcl_constr _ -> ()
-  | Pcl_structure cs -> class_structure ppf tbl cs;
-  | Pcl_fun (_, _, _, ce) -> class_expr ppf tbl ce;
-  | Pcl_apply (ce, lel) ->
-      class_expr ppf tbl ce;
-      List.iter (fun (_, e) -> expression ppf tbl e) lel;
-  | Pcl_let (recflag, pel, ce) ->
-      let_pel ppf tbl recflag pel (Some (fun ppf tbl -> class_expr ppf tbl ce));
-  | Pcl_constraint (ce, _) -> class_expr ppf tbl ce;
-
-and class_structure ppf tbl (p, cfl) =
-  let defined = get_vars ([], []) p in
-  add_vars tbl defined;
-  List.iter (class_field ppf tbl) cfl;
-  check_rm_vars ppf tbl defined;
-
-and class_field ppf tbl cf =
-  match cf with
-  | Pcf_inher (_, ce, _) -> class_expr ppf tbl ce;
-  | Pcf_val (_, _, _, e, _) -> expression ppf tbl e;
-  | Pcf_virt _ | Pcf_valvirt _ -> ()
-  | Pcf_meth (_, _, _, e, _) -> expression ppf tbl e;
-  | Pcf_cstr _ -> ()
-  | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None;
-  | Pcf_init e -> expression ppf tbl e;
-;;
-
-let warn ppf ast =
-  if Warnings.is_active (w_suspicious "") || Warnings.is_active (w_strict "")
-  then begin
-    let tbl = Hashtbl.create 97 in
-    structure ppf tbl ast;
-  end;
-  ast
-;;

diff --git a/typing/unused_var.mli b/typing/unused_var.mli
deleted file mode 100644 (file)
index be36fcc..0000000
--- a/typing/unused_var.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(***********************************************************************)
-(*                                                                     *)
-(*                           Objective Caml                            *)
-(*                                                                     *)
-(*           Damien Doligez, projet Cristal, INRIA Rocquencourt        *)
-(*                                                                     *)
-(*  Copyright 2004 Institut National de Recherche en Informatique et   *)
-(*  en Automatique.  All rights reserved.  This file is distributed    *)
-(*  under the terms of the Q Public License version 1.0.               *)
-(*                                                                     *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-val warn : Format.formatter -> Parsetree.structure -> Parsetree.structure;;
-(* Warn on unused variables; return the second argument. *)

diff --git a/utils/.cvsignore b/utils/.cvsignore
deleted file mode 100644 (file)
index 25b6d3b..0000000
--- a/utils/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-config.ml

diff --git a/utils/.ignore b/utils/.ignore
new file mode 100644 (file)
index 0000000..25b6d3b
--- /dev/null
+++ b/utils/.ignore
@@ -0,0 +1 @@
+config.ml

diff --git a/utils/ccomp.ml b/utils/ccomp.ml
index 94a29217dc7ae2fd9711b1e017b7b2ef0d4e1218..66525e5b9eb5d73722cb2c225c3770e2c227076e 100644 (file)
--- a/utils/ccomp.ml
+++ b/utils/ccomp.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -73,9 +73,10 @@ let create_archive archive file_list =
       command(Printf.sprintf "link /lib /nologo /out:%s %s"
                              quoted_archive (quote_files file_list))
   | _ ->
+      assert(String.length Config.ar > 0);
       let r1 =
-        command(Printf.sprintf "ar rc %s %s"
-                quoted_archive (quote_files file_list)) in
+        command(Printf.sprintf "%s rc %s %s"
+                Config.ar quoted_archive (quote_files file_list)) in
       if r1 <> 0 || String.length Config.ranlib = 0
       then r1
       else command(Config.ranlib ^ " " ^ quoted_archive)

diff --git a/utils/ccomp.mli b/utils/ccomp.mli
index 72ae7131457c353cd4f6131589a2617edeea5983..687c701fa71d2f7da6b31927c5e5962538429542 100644 (file)
--- a/utils/ccomp.mli
+++ b/utils/ccomp.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/utils/clflags.ml b/utils/clflags.ml
index 1074d3628c5ae462f5c9cb4d3dd4be7640c93c3b..51c80ed0e5641ab859f37483dc68a655426a70d1 100644 (file)
--- a/utils/clflags.ml
+++ b/utils/clflags.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -39,6 +39,7 @@ and use_vmthreads = ref false           (* -vmthread *)
 and noassert = ref false                (* -noassert *)
 and verbose = ref false                 (* -verbose *)
 and noprompt = ref false                (* -noprompt *)
+and nopromptcont = ref false            (* -nopromptcont *)
 and init_file = ref (None : string option)   (* -init *)
 and use_prims = ref ""                  (* -use-prims ... *)
 and use_runtime = ref ""                (* -use-runtime ... *)
@@ -46,16 +47,18 @@ and principal = ref false               (* -principal *)
 and recursive_types = ref false         (* -rectypes *)
 and strict_sequence = ref false         (* -strict-sequence *)
 and applicative_functors = ref true     (* -no-app-funct *)
-and make_runtime = ref false            (* -make_runtime *)
+and make_runtime = ref false            (* -make-runtime *)
 and gprofile = ref false                (* -p *)
 and c_compiler = ref (None: string option) (* -cc *)
 and no_auto_link = ref false            (* -noautolink *)
 and dllpaths = ref ([] : string list)   (* -dllpath *)
 and make_package = ref false            (* -pack *)
 and for_package = ref (None: string option) (* -for-pack *)
+and error_size = ref 500                (* -error-size *)
 let dump_parsetree = ref false          (* -dparsetree *)
 and dump_rawlambda = ref false          (* -drawlambda *)
 and dump_lambda = ref false             (* -dlambda *)
+and dump_clambda = ref false            (* -dclambda *)
 and dump_instr = ref false              (* -dinstr *)
 
 let keep_asm_file = ref false           (* -S *)
@@ -92,3 +95,5 @@ let std_include_dir () =
 
 let shared = ref false (* -shared *)
 let dlcode = ref true (* not -nodynlink *)
+
+let runtime_variant = ref "";;     (* -runtime-variant *)

diff --git a/utils/clflags.mli b/utils/clflags.mli
index d5357ef396171707672e58895b562e3664f3526f..4cff375a4efb7deddc02442ce3e39425083aa30a 100644 (file)
--- a/utils/clflags.mli
+++ b/utils/clflags.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -36,6 +36,7 @@ val use_vmthreads : bool ref
 val noassert : bool ref
 val verbose : bool ref
 val noprompt : bool ref
+val nopromptcont : bool ref
 val init_file : string option ref
 val use_prims : string ref
 val use_runtime : string ref
@@ -50,9 +51,11 @@ val no_auto_link : bool ref
 val dllpaths : string list ref
 val make_package : bool ref
 val for_package : string option ref
+val error_size : int ref
 val dump_parsetree : bool ref
 val dump_rawlambda : bool ref
 val dump_lambda : bool ref
+val dump_clambda : bool ref
 val dump_instr : bool ref
 val keep_asm_file : bool ref
 val optimize_for_speed : bool ref
@@ -76,3 +79,4 @@ val std_include_flag : string -> string
 val std_include_dir : unit -> string list
 val shared : bool ref
 val dlcode : bool ref
+val runtime_variant : string ref

diff --git a/utils/config.mlbuild b/utils/config.mlbuild
index 68a7c858491c21c599a64e7b33fd34e2ea36b2ae..ca6e6d47675879ecb5a964fc6617f4c20c6e0223 100644 (file)
--- a/utils/config.mlbuild
+++ b/utils/config.mlbuild
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -55,19 +55,20 @@ let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts
 let native_c_libraries = C.nativecclibs
 let native_pack_linker = C.packld
 let ranlib = C.ranlibcmd
+let ar = C.arcmd
 let cc_profile = C.cc_profile
 let mkdll = C.mkdll
 let mkexe = C.mkexe
 let mkmaindll = C.mkmaindll
 
 let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I012"
+and cmi_magic_number = "Caml1999I013"
 and cmo_magic_number = "Caml1999O007"
 and cma_magic_number = "Caml1999A008"
 and cmx_magic_number = "Caml1999Y011"
 and cmxa_magic_number = "Caml1999Z010"
-and ast_impl_magic_number = "Caml1999M013"
-and ast_intf_magic_number = "Caml1999N012"
+and ast_impl_magic_number = "Caml1999M014"
+and ast_intf_magic_number = "Caml1999N013"
 and cmxs_magic_number = "Caml2007D001"
 
 let load_path = ref ([] : string list)
@@ -88,6 +89,7 @@ let model = C.model
 let system = C.system
 
 let asm = C.asm
+let asm_cfi_supported = C.asm_cfi_supported
 
 let ext_obj = C.ext_obj
 let ext_asm = C.ext_asm
@@ -121,6 +123,7 @@ let print_config oc =
   p "model" model;
   p "system" system;
   p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
   p "ext_obj" ext_obj;
   p "ext_asm" ext_asm;
   p "ext_lib" ext_lib;

diff --git a/utils/config.mli b/utils/config.mli
index da39808bda7f7153c9818182ca3992583ee50c37..822df4b061d18ff1762bf03a91f31b3134eeac66 100644 (file)
--- a/utils/config.mli
+++ b/utils/config.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -22,10 +22,9 @@ val standard_library: string
 val standard_runtime: string
         (* The full path to the standard bytecode interpreter ocamlrun *)
 val ccomp_type: string
-        (* The "kind" of the C compiler: one of
+        (* The "kind" of the C compiler, assembler and linker used: one of
                "cc" (for Unix-style C compilers)
-               "msvc" (Microsoft Visual C++)
-               "mrc" (Macintosh MPW) *)
+               "msvc" (for Microsoft Visual C++ and MASM) *)
 val bytecomp_c_compiler: string
         (* The C compiler to use for compiling C files
            with the bytecode compiler *)
@@ -47,6 +46,8 @@ val mkmaindll: string
         (* The linker command line to build main programs as dlls. *)
 val ranlib: string
         (* Command to randomize a library, or "" if not needed *)
+val ar: string
+        (* Name of the ar command, or "" if not needed  (MSVC) *)
 val cc_profile : string
         (* The command line option to the C compiler to enable profiling. *)
 
@@ -98,6 +99,9 @@ val asm: string
         (* The assembler (and flags) to use for assembling
            ocamlopt-generated code. *)
 
+val asm_cfi_supported: bool
+        (* Whether assembler understands CFI directives *)
+
 val ext_obj: string
         (* Extension for object files, e.g. [.o] under Unix. *)
 val ext_asm: string

diff --git a/utils/config.mlp b/utils/config.mlp
index 4cabf90bfa0fe95999804e880ac97dda150edeac..9b3edb9896e576f6cd2f912d734a042b2df65c06 100644 (file)
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -44,19 +44,20 @@ let native_c_compiler = "%%NATIVECC%%"
 let native_c_libraries = "%%NATIVECCLIBS%%"
 let native_pack_linker = "%%PACKLD%%"
 let ranlib = "%%RANLIBCMD%%"
+let ar = "%%ARCMD%%"
 let cc_profile = "%%CC_PROFILE%%"
 let mkdll = "%%MKDLL%%"
 let mkexe = "%%MKEXE%%"
 let mkmaindll = "%%MKMAINDLL%%"
 
 let exec_magic_number = "Caml1999X008"
-and cmi_magic_number = "Caml1999I012"
+and cmi_magic_number = "Caml1999I013"
 and cmo_magic_number = "Caml1999O007"
 and cma_magic_number = "Caml1999A008"
 and cmx_magic_number = "Caml1999Y011"
 and cmxa_magic_number = "Caml1999Z010"
-and ast_impl_magic_number = "Caml1999M013"
-and ast_intf_magic_number = "Caml1999N012"
+and ast_impl_magic_number = "Caml1999M014"
+and ast_intf_magic_number = "Caml1999N013"
 and cmxs_magic_number = "Caml2007D001"
 
 let load_path = ref ([] : string list)
@@ -77,6 +78,7 @@ let model = "%%MODEL%%"
 let system = "%%SYSTEM%%"
 
 let asm = "%%ASM%%"
+let asm_cfi_supported = %%ASM_CFI_SUPPORTED%%
 
 let ext_obj = "%%EXT_OBJ%%"
 let ext_asm = "%%EXT_ASM%%"
@@ -110,6 +112,7 @@ let print_config oc =
   p "model" model;
   p "system" system;
   p "asm" asm;
+  p_bool "asm_cfi_supported" asm_cfi_supported;
   p "ext_obj" ext_obj;
   p "ext_asm" ext_asm;
   p "ext_lib" ext_lib;

diff --git a/utils/consistbl.ml b/utils/consistbl.ml
index d01d7c873565fa102f1bfb4165f7a63f57b00f6a..f724e4f8f79b7bc2a9ae8b369e65c651212b43de 100644 (file)
--- a/utils/consistbl.ml
+++ b/utils/consistbl.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/utils/consistbl.mli b/utils/consistbl.mli
index edaac12fc5b725596e2a56c79d685ed54b6d0e59..a877733b5e7819a34f17997a3c61194dc9d35855 100644 (file)
--- a/utils/consistbl.mli
+++ b/utils/consistbl.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/utils/misc.ml b/utils/misc.ml
index 68ca8e3dac8e5c716ecfa962b226653ec88b3bbf..1f5bb98b1abcc80b1d46ed26b0f387934f9d1e50 100644 (file)
--- a/utils/misc.ml
+++ b/utils/misc.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -21,12 +21,10 @@ let fatal_error msg =
 
 (* Exceptions *)
 
-let try_finally f1 f2 =
-  try
-    let result = f1 () in
-    f2 ();
-    result
-  with x -> f2 (); raise x
+let try_finally work cleanup =
+  let result = (try work () with e -> cleanup (); raise e) in
+  cleanup ();
+  result
 ;;
 
 (* List functions *)
@@ -143,6 +141,14 @@ let copy_file_chunk ic oc len =
     end
   in copy len
 
+(* Reading from a channel *)
+
+let input_bytes ic n =
+  let result = String.create n in
+  really_input ic result 0 n;
+  result
+;;
+
 (* Integer operations *)
 
 let rec log2 n =
@@ -195,3 +201,7 @@ let rev_split_words s =
       | _ -> split2 res i (j+1)
     end
   in split1 [] 0
+
+let get_ref r =
+  let v = !r in
+  r := []; v

diff --git a/utils/misc.mli b/utils/misc.mli
index 87f74e2575398c4d640177199a194191d7d16142..6ccb1b66bedb9a782f485c3333f926eb3eba4a07 100644 (file)
--- a/utils/misc.mli
+++ b/utils/misc.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)
@@ -66,6 +66,11 @@ val copy_file_chunk: in_channel -> out_channel -> int -> unit
            them to [oc]. It raises [End_of_file] when encountering
            EOF on [ic]. *)
 
+val input_bytes : in_channel -> int -> string;;
+        (* [input_bytes ic n] reads [n] bytes from [ic] and returns them
+           in a new string.  It raises [End_of_file] if EOF is encountered
+           before all the bytes are read. *)
+
 val log2: int -> int
         (* [log2 n] returns [s] such that [n = 1 lsl s]
            if [n] is a power of 2*)
@@ -102,3 +107,7 @@ val search_substring: string -> string -> int -> int
 val rev_split_words: string -> string list
         (* [rev_split_words s] splits [s] in blank-separated words, and return
            the list of words in reverse order. *)
+
+val get_ref: 'a list ref -> 'a list
+        (* [get_ref lr] returns the content of the list reference [lr] and reset
+           its content to the empty list. *)

diff --git a/utils/tbl.ml b/utils/tbl.ml
index b06516931db56c46d59c893a4faf891e1ad8fa50..63c133a205eb958c5c2709532254a246efb7bb5c 100644 (file)
--- a/utils/tbl.ml
+++ b/utils/tbl.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/utils/tbl.mli b/utils/tbl.mli
index 44a021a7855f6e62d596936f18ec866c3d13bfbb..626fd4c13200f5ac58c056ff518fb6a895dbae4b 100644 (file)
--- a/utils/tbl.mli
+++ b/utils/tbl.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/utils/terminfo.ml b/utils/terminfo.ml
index cc1799108168f08cb4771b6a3ac30d81f37af240..4619ac61c64c3a672dd54e6eeffecae35fa79476 100644 (file)
--- a/utils/terminfo.ml
+++ b/utils/terminfo.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/utils/terminfo.mli b/utils/terminfo.mli
index ef26b61a51f7ab370c6454051f677a3d94dc7e77..5fa3aa14e751374823ef1e2a2cbbef5062f5b414 100644 (file)
--- a/utils/terminfo.mli
+++ b/utils/terminfo.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
 (*                                                                     *)

diff --git a/utils/warnings.ml b/utils/warnings.ml
index 72885523c0fd209e3af38b6683de8905502efa94..e633c562aca661225a82643c9fbffafe89d9c0a9 100644 (file)
--- a/utils/warnings.ml
+++ b/utils/warnings.ml
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis && Damien Doligez, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -50,6 +50,14 @@ type t =
   | Wildcard_arg_to_constant_constr         (* 28 *)
   | Eol_in_string                           (* 29 *)
   | Duplicate_definitions of string * string * string * string (*30 *)
+  | Multiple_definition of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_exception of string * bool       (* 38 *)
 ;;
 
 (* If you remove a warning, leave a hole in the numbering.  NEVER change
@@ -89,9 +97,17 @@ let number = function
   | Wildcard_arg_to_constant_constr -> 28
   | Eol_in_string -> 29
   | Duplicate_definitions _ -> 30
+  | Multiple_definition _ -> 31
+  | Unused_value_declaration _ -> 32
+  | Unused_open _ -> 33
+  | Unused_type_declaration _ -> 34
+  | Unused_for_index _ -> 35
+  | Unused_ancestor _ -> 36
+  | Unused_constructor _ -> 37
+  | Unused_exception _ -> 38
 ;;
 
-let last_warning_number = 30;;
+let last_warning_number = 38;;
 (* Must be the max number returned by the [number] function. *)
 
 let letter = function
@@ -107,7 +123,7 @@ let letter = function
   | 'h' -> []
   | 'i' -> []
   | 'j' -> []
-  | 'k' -> []
+  | 'k' -> [32; 33; 34; 35; 36; 37; 38]
   | 'l' -> [6]
   | 'm' -> [7]
   | 'n' -> []
@@ -186,7 +202,7 @@ let parse_opt flags s =
 let parse_options errflag s = parse_opt (if errflag then error else active) s;;
 
 (* If you change these, don't forget to change them in man/ocamlc.m *)
-let defaults_w = "+a-4-6-7-9-27..29";;
+let defaults_w = "+a-4-6-7-9-27-29-32..38";;
 let defaults_warn_error = "-a";;
 
 let () = parse_options false defaults_w;;
@@ -219,7 +235,7 @@ let message = function
        Here is an example of a value that is not matched:\n" ^ s
   | Non_closed_record_pattern s ->
       "the following labels are not bound in this record pattern:\n" ^ s ^
-      "\nEither bind these labels explicitly or add `; _' to the pattern."
+      "\nEither bind these labels explicitly or add '; _' to the pattern."
   | Statement_type ->
       "this expression should have type unit."
   | Unused_match -> "this match case is unused."
@@ -246,8 +262,8 @@ let message = function
       "this statement never returns (or has an unsound type.)"
   | Camlp4 s -> s
   | Useless_record_with ->
-      "this record is defined by a `with' expression,\n\
-       but no fields are borrowed from the original."
+      "all the fields are explicitly listed in this record:\n\
+       the 'with' clause is useless."
   | Bad_module_name (modname) ->
       "bad source file name: \"" ^ modname ^ "\" is not a valid module name."
   | All_clauses_guarded ->
@@ -260,6 +276,30 @@ let message = function
   | Duplicate_definitions (kind, cname, tc1, tc2) ->
       Printf.sprintf "the %s %s is defined in both types %s and %s."
         kind cname tc1 tc2
+  | Multiple_definition(modname, file1, file2) ->
+      Printf.sprintf
+        "files %s and %s both define a module named %s"
+        file1 file2 modname
+  | Unused_value_declaration v -> "unused value " ^ v ^ "."
+  | Unused_open s -> "unused open " ^ s ^ "."
+  | Unused_type_declaration s -> "unused type " ^ s ^ "."
+  | Unused_for_index s -> "unused for-loop index " ^ s ^ "."
+  | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "."
+  | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "."
+  | Unused_constructor (s, true, _) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        (However, this constructor appears in patterns.)"
+  | Unused_constructor (s, false, true) ->
+      "constructor " ^ s ^
+      " is never used to build values.\n\
+        Its type is exported as a private type."
+  | Unused_exception (s, false) ->
+      "unused exception constructor " ^ s ^ "."
+  | Unused_exception (s, true) ->
+      "exception constructor " ^ s ^
+      " is never raised or used to build values.\n\
+        (However, this constructor appears in patterns.)"
 ;;
 
 let nerrors = ref 0;;
@@ -293,7 +333,6 @@ let check_fatal () =
   end;
 ;;
 
-
 let descriptions =
   [
     1, "Suspicious-looking start-of-comment mark.";
@@ -305,14 +344,14 @@ let descriptions =
     5, "Partially applied function: expression whose result has function\n\
    \    type and is ignored.";
     6, "Label omitted in function application.";
-    7, "Some methods are overridden in the class where they are defined.";
+    7, "Method overridden.";
     8, "Partial match: missing cases in pattern-matching.";
     9, "Missing fields in a record pattern.";
    10, "Expression on the left-hand side of a sequence that doesn't have type\n\
    \    \"unit\" (and that is not a function, see warning number 5).";
    11, "Redundant case in a pattern matching (unused match case).";
    12, "Redundant sub-pattern in a pattern-matching.";
-   13, "Override of an instance variable.";
+   13, "Instance variable overridden.";
    14, "Illegal backslash escape in a string constant.";
    15, "Private method made public implicitly.";
    16, "Unerasable optional argument.";
@@ -323,11 +362,13 @@ let descriptions =
    21, "Non-returning statement.";
    22, "Camlp4 warning.";
    23, "Useless record \"with\" clause.";
-   24, "Bad module name: the source file name is not a valid OCaml module name.";
+   24, "Bad module name: the source file name is not a valid OCaml module \
+        name.";
    25, "Pattern-matching with all clauses guarded.  Exhaustiveness cannot be\n\
-   \    checked";
-   26, "Suspicious unused variable: unused variable that is bound with \"let\"\n\
-   \    or \"as\", and doesn't start with an underscore (\"_\") character.";
+   \    checked.";
+   26, "Suspicious unused variable: unused variable that is bound\n\
+   \    with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\
+   \    character.";
    27, "Innocuous unused variable: unused variable that is not bound with\n\
    \    \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\
    \    character.";
@@ -335,8 +376,30 @@ let descriptions =
    29, "Unescaped end-of-line in a string constant (non-portable code).";
    30, "Two labels or constructors of the same name are defined in two\n\
    \    mutually recursive types.";
+   31, "A module is linked twice in the same executable.";
+   32, "Unused value declaration.";
+   33, "Unused open statement.";
+   34, "Unused type declaration.";
+   35, "Unused for-loop index.";
+   36, "Unused ancestor variable.";
+   37, "Unused constructor.";
+   38, "Unused exception constructor.";
   ]
+;;
 
 let help_warnings () =
   List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions;
+  print_endline "  A All warnings.";
+  for i = Char.code 'b' to Char.code 'z' do
+    let c = Char.chr i in
+    match letter c with
+    | [] -> ()
+    | [n] ->
+        Printf.printf "  %c Synonym for warning %i.\n" (Char.uppercase c) n
+    | l ->
+        Printf.printf "  %c Set of warnings %s.\n"
+          (Char.uppercase c)
+          (String.concat ", " (List.map string_of_int l))
+  done;
   exit 0
+;;

diff --git a/utils/warnings.mli b/utils/warnings.mli
index c9e577d9f397d26e71f7a629e45189b8f2362eb1..c7542af8cd918182e44ef6e97a146b6e543faa6e 100644 (file)
--- a/utils/warnings.mli
+++ b/utils/warnings.mli
@@ -1,6 +1,6 @@
 (***********************************************************************)
 (*                                                                     *)
-(*                           Objective Caml                            *)
+(*                                OCaml                                *)
 (*                                                                     *)
 (*            Pierre Weis && Damien Doligez, INRIA Rocquencourt        *)
 (*                                                                     *)
@@ -45,6 +45,14 @@ type t =
   | Wildcard_arg_to_constant_constr         (* 28 *)
   | Eol_in_string                           (* 29 *)
   | Duplicate_definitions of string * string * string * string (*30 *)
+  | Multiple_definition of string * string * string (* 31 *)
+  | Unused_value_declaration of string      (* 32 *)
+  | Unused_open of string                   (* 33 *)
+  | Unused_type_declaration of string       (* 34 *)
+  | Unused_for_index of string              (* 35 *)
+  | Unused_ancestor of string               (* 36 *)
+  | Unused_constructor of string * bool * bool  (* 37 *)
+  | Unused_exception of string * bool       (* 38 *)
 ;;
 
 val parse_options : bool -> string -> unit;;

diff --git a/win32caml/Makefile b/win32caml/Makefile
deleted file mode 100644 (file)
index a73b731..0000000
--- a/win32caml/Makefile
+++ /dev/null
@@ -1,57 +0,0 @@
-#########################################################################
-#                                                                       #
-#                            Objective Caml                             #
-#                                                                       #
-#            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
-#                                                                       #
-#   Copyright 2001 Institut National de Recherche en Informatique et    #
-#   en Automatique.  All rights reserved.  This file is distributed     #
-#   under the terms of the GNU Library General Public License, with     #
-#   the special exception on linking described in file ../LICENSE.      #
-#                                                                       #
-#########################################################################
-
-# $Id$
-
-include ../config/Makefile
-
-CC=$(BYTECC)
-CFLAGS=$(BYTECCCOMPOPTS)
-
-OBJS=startocaml.$(O) ocamlres.$(O) ocaml.$(O) menu.$(O) \
-  history.$(O) editbuffer.$(O)
-
-LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,advapi32) $(call SYSLIB,gdi32) \
-     $(call SYSLIB,user32) $(call SYSLIB,comdlg32) $(call SYSLIB,comctl32)
-
-all: ocamlwin.exe
-
-ocamlwin.exe: $(OBJS)
-       $(MKEXE) -o ocamlwin.exe $(OBJS) $(LIBS) $(EXTRALIBS) -subsystem windows
-
-ocamlres.$(O): ocaml.rc ocaml.ico
-ifeq ($(TOOLCHAIN),msvc)
-       rc ocaml.rc
-ifeq ($(ARCH),amd64)
-       cvtres /nologo /machine:amd64 /out:$@ ocaml.res
-else
-       cvtres /nologo /machine:ix86 /out:$@ ocaml.res
-endif
-       rm -f ocaml.res
-endif
-ifeq ($(TOOLCHAIN),mingw)
-       windres -i ocaml.rc -o $@
-endif
-
-$(OBJS): inria.h inriares.h history.h editbuffer.h
-
-clean:
-       rm -f ocamlwin.exe *.$(O) *.pdb ocamlwin.ilk
-
-install:
-       cp ocamlwin.exe $(PREFIX)/OCamlWin.exe
-
-.SUFFIXES: .c .$(O)
-
-.c.$(O):
-       $(CC) $(CFLAGS) -c $*.c

diff --git a/win32caml/editbuffer.c b/win32caml/editbuffer.c
deleted file mode 100644 (file)
index 480d22d..0000000
--- a/win32caml/editbuffer.c
+++ /dev/null
@@ -1,514 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-#include <string.h>
-#include <stdlib.h>
-#include "inriares.h"
-#include "inria.h"
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_addline ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Adds a line to the current edit buffer
- Input:                        Line of text to append to the end
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-       18 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Corrected doubly linked list issue
-------------------------------------------------------------------------*/
-BOOL editbuffer_addline(EditBuffer* edBuf, char* line)
-{
-       LineList *tail = NULL; //head of the edit buffer line list
-       LineList *newline = NULL;
-
-       // sanity check
-       if(edBuf == NULL)
-       {
-               return FALSE;
-       }
-
-       // perform edit buffer sanity checks
-       if((edBuf->LineCount < 0) || (edBuf->Lines == NULL))
-       {
-               edBuf->LineCount = 0;
-       }
-
-       // move to the end of the line list in the edit buffer
-       if((tail = edBuf->Lines) != NULL)
-               for( ; tail->Next != NULL; tail = tail->Next);
-
-       // create the new line entry
-       newline = (LineList*)SafeMalloc(sizeof(LineList));
-       newline->Next = NULL;
-       newline->Prev = tail;
-       newline->Text = (char*)SafeMalloc(strlen(line)+1);
-       strncpy(newline->Text, line, strlen(line)+1);
-       newline->Text[strlen(line)] = '\0';
-
-       // add it to the list as the head or the tail
-       if(tail != NULL)
-       {
-               tail->Next = newline;
-       } else {
-               edBuf->Lines = newline;
-       }
-
-       // update the number of lines in the buffer
-       edBuf->LineCount++;
-
-       return TRUE;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_updateline ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Updates the edit buffer's internal contents for a line
- Input:                        idx - Line index
-                               line - String to add
- Output:               if the line was updated or not
- Errors:
-------------------------------------------------------------------------*/
-BOOL editbuffer_updateline(EditBuffer* edBuf, int idx, char* line)
-{
-       LineList *update = edBuf->Lines; //head of the edit buffer line list
-       LineList *newline = NULL;
-       int i;
-
-       // sanity checks
-       if(edBuf == NULL)
-       {
-               return FALSE;
-       } else if(      (edBuf->LineCount == 0) ||
-                               (edBuf->Lines == NULL) ||
-                               (idx >= edBuf->LineCount) ||
-                               (idx < 0) ) {
-               return FALSE;
-       }
-
-       // move to the index in the line list
-       // i left in update != NULL as a sanity check
-       for(i = 0; ((update != NULL) && (i != idx)); update = update->Next, i++);
-
-       // did things mess up?
-       if( (update == NULL) || (i != idx) )
-       {
-               return FALSE;
-       }
-
-       // get rid of the old line
-       free(update->Text);
-
-       // get the new line updated
-       update->Text = (char*)SafeMalloc(strlen(line)+1);
-       strncpy(update->Text, line, strlen(line)+1);
-       update->Text[strlen(line)] = '\0';
-
-       return TRUE;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_updateoraddline ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Updates the edit buffer's internal contents for a line
- Input:                        idx - Line index
-                               line - String to add
- Output:               if the line was updated or not
- Errors:
-------------------------------------------------------------------------*/
-BOOL editbuffer_updateoraddline(EditBuffer* edBuf, int idx, char* line)
-{
-       LineList *update;
-
-       // sanity checks
-       if(edBuf == NULL)
-       {
-               return FALSE;
-       } else if((idx > edBuf->LineCount) || (idx < 0)) {
-               return FALSE;
-       }
-
-       update = edBuf->Lines; //head of the edit buffer line list
-
-       // do we update or add?
-       if((idx < edBuf->LineCount) && (edBuf->Lines != NULL))
-       {       //interior line, update
-               return editbuffer_updateline(edBuf, idx, line);
-       } else {
-               //fence line, add
-               return editbuffer_addline(edBuf, line);
-       }
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_removeline ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Removes a line from the edit buffer
- Input:                        idx - Line index to remove
- Output:               if the line was removed or not
- Errors:
---------------------------------------------------------------------------
- Edit History:
-       18 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added to allow backspace and delete support
-               - Corrected doubly linked list issue
-------------------------------------------------------------------------*/
-BOOL editbuffer_removeline(EditBuffer* edBuf, int idx)
-{
-       LineList *update = NULL;
-       int i = 0;
-
-       // sanity checks
-       if(edBuf == NULL)
-       {
-               return FALSE;
-       } else if(      (edBuf->LineCount == 0) ||
-                               (edBuf->Lines == NULL) ||
-                               (idx >= edBuf->LineCount) ||
-                               (idx < 0) ) {
-               return FALSE;
-       }
-       
-       // move to the index in the line list
-       // i left in update != NULL as a sanity check
-       for(i = 0, update = edBuf->Lines; ((update != NULL) && (i != idx)); update = update->Next, i++);
-
-       // remove this line
-       if(update != NULL)
-       {
-               // break links, removing our line
-               if(update->Prev != NULL)
-               {
-                       // we're not the first so just break the link
-                       update->Prev->Next = update->Next;
-                       
-                       // fix the prev check
-                       if(update->Next != NULL)
-                               update->Next->Prev = update->Prev;
-               } else {
-                       // we're the first, attach the next guy to lines
-                       edBuf->Lines = update->Next;
-               }
-
-               // one less line to worry about
-               edBuf->LineCount--;
-
-               // get rid of the text
-               if(update->Text != NULL)
-                       free(update->Text);
-
-               // get rid of us
-               free(update);
-
-               return TRUE;
-       }
-
-       return FALSE;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_getasline ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Returns the edit buffer as one big line, \n's and \t's
-                               become spaces.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-char* editbuffer_getasline(EditBuffer* edBuf)
-{
-       LineList *line = NULL; //head of the edit buffer line list
-       char* retline = (char*)realloc(NULL, 1);
-       unsigned int i = 0;
-
-       // fix retline bug
-       retline[0] = '\0';
-
-       // sanity checks
-       if(edBuf == NULL)
-       {
-               return NULL;
-       } else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
-               // fix any possible errors that may come from this
-               edBuf->LineCount = 0;
-               edBuf->Lines = NULL;
-               return NULL;
-       }
-
-       // get the big line
-       for(line = edBuf->Lines; line != NULL; line = line->Next)
-       {
-               if(line->Text != NULL)
-               {
-                       retline = (char*)realloc(retline, (strlen(retline) + strlen(line->Text) + (strlen(retline) > 0 ? 2 : 1)));
-
-                       if(strlen(retline) > 0)
-                               retline = strcat(retline, " ");
-
-                       retline = strcat(retline, line->Text);
-
-                       //concat in the hoouuusssseee!
-               }
-       }
-
-       // now we have the big line, so lets ditch all \n's \t's and \r's
-       for(i = 0; i < strlen(retline); i++)
-       {
-               switch(retline[i])
-               {
-                       case '\n':
-                       case '\t':
-                       case '\r':
-                               retline[i] = ' ';
-               }
-       }
-
-       return retline;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_getasbuffer ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Returns the edit buffer as one big line, \n's and \t's
-                               become spaces.
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-char* editbuffer_getasbuffer(EditBuffer* edBuf)
-{
-       LineList *line = NULL; //head of the edit buffer line list
-       char* retbuf = (char*)realloc(NULL, 1);
-       unsigned int i = 0;
-
-       // fix retline bug
-       retbuf[0] = '\0';
-
-       // sanity checks
-       if(edBuf == NULL)
-       {
-               return NULL;
-       } else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
-               // fix any possible errors that may come from this
-               edBuf->LineCount = 0;
-               edBuf->Lines = NULL;
-               return NULL;
-       }
-
-       // get the big line
-       for(line = edBuf->Lines; line != NULL; line = line->Next)
-       {
-               if(line->Text != NULL)
-               {
-                       int len = strlen(retbuf);
-                       len += strlen(line->Text) + (len > 0 ? 3 : 1);
-
-                       retbuf = (char*)realloc(retbuf, len);
-
-                       if(strlen(retbuf) > 0)
-                               retbuf = strcat(retbuf, "\r\n");
-
-                       retbuf = strcat(retbuf, line->Text);
-
-                       retbuf[len-1] = '\0';
-
-                       //concat in the hoouuusssseee!
-               }
-       }
-
-       return retbuf;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_lastline ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Returns the last line in the edit buffer
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-char* editbuffer_lastline(EditBuffer* edBuf)
-{
-       LineList *line = NULL; //head of the edit buffer line list
-
-       // sanity checks
-       if(edBuf == NULL)
-       {
-               return NULL;
-       } else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
-               // fix any possible errors that may come from this
-               edBuf->LineCount = 0;
-               edBuf->Lines = NULL;
-               return NULL;
-       }
-
-       // go to the last line
-       for(line = edBuf->Lines; line->Next != NULL; line = line->Next);
-
-       return line->Text;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_copy ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Makes an exact copy of an edit buffer
- Input:
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-       16 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added to make copies of history entries
-       18 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Corrected doubly linked list issue
-       06 Oct  2003 - Chris Watford watford@uiuc.edu
-               - Added isCorrect flag
-------------------------------------------------------------------------*/
-EditBuffer* editbuffer_copy(EditBuffer* edBuf)
-{
-       // sanity checks
-       if(edBuf == NULL)
-       {
-               return NULL;
-       } else {
-               EditBuffer* copy = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
-               LineList* lines = edBuf->Lines;
-               LineList* lastLine = NULL;
-
-               // clear its initial values
-               copy->LineCount = 0;
-               copy->Lines = NULL;
-               copy->isCorrect = FALSE;
-
-               // well we don't have to copy much
-               if((lines == NULL) || (edBuf->LineCount <= 0))
-               {
-                       return copy;
-               }
-
-               // get if its correct
-               copy->isCorrect = edBuf->isCorrect;
-
-               // go through each line, malloc it and add it
-               for( ; lines != NULL; lines = lines->Next)
-               {
-                       LineList* curline = (LineList*)SafeMalloc(sizeof(LineList));
-                       curline->Next = NULL;
-                       curline->Prev = NULL;
-
-                       // if there was a last line, link them to us
-                       if(lastLine != NULL)
-                       {
-                               lastLine->Next = curline;
-                               curline->Prev = lastLine;
-                       }
-
-                       // are we the first line? add us to the edit buffer as the first
-                       if(copy->Lines == NULL)
-                       {
-                               copy->Lines = curline;
-                       }
-
-                       // check if there is text on the line
-                       if(lines->Text == NULL)
-                       {       // no text, make it blankz0r
-                               curline->Text = (char*)SafeMalloc(sizeof(char));
-                               curline->Text[0] = '\0';
-                       } else {
-                               // there is text, copy it and null-terminate
-                               curline->Text = (char*)SafeMalloc(strlen(lines->Text) + 1);
-                               strncpy(curline->Text, lines->Text, strlen(lines->Text));
-                               curline->Text[strlen(lines->Text)] = '\0';
-                       }
-
-                       // up the line count and make us the last line
-                       copy->LineCount++;
-                       lastLine = curline;
-               }
-
-               // return our new copy
-               return copy;
-       }
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_destroy ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Destroys an edit buffer
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-void editbuffer_destroy(EditBuffer* edBuf)
-{
-       // sanity checks
-       if(edBuf == NULL)
-       {       // nothing to do
-               return;
-       } else if(edBuf->Lines != NULL) {
-               LineList* lastline = NULL;
-
-               // loop through each line free'ing its text
-               for( ; edBuf->Lines != NULL; edBuf->Lines = edBuf->Lines->Next)
-               {
-                       if(edBuf->Lines->Text != NULL)
-                               free(edBuf->Lines->Text);
-
-                       // if there was a line before us, free it
-                       if(lastline != NULL)
-                       {
-                               free(lastline);
-                               lastline = NULL;
-                       }
-
-                       lastline = edBuf->Lines;
-               }
-
-               // free the last line
-               free(lastline);
-       }
-
-       // free ourself
-       free(edBuf);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     editbuffer_new ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Creates an edit buffer
- Input:
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-       06 Oct  2003 - Chris Watford watford@uiuc.edu
-               - Added isCorrect flag
-------------------------------------------------------------------------*/
-EditBuffer* editbuffer_new(void)
-{
-       // create a new one
-       EditBuffer *edBuf = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
-       
-       // default vals
-       edBuf->LineCount = 0;
-       edBuf->Lines = NULL;
-       edBuf->isCorrect = FALSE;
-       
-       // return it
-       return edBuf;
-}

diff --git a/win32caml/editbuffer.h b/win32caml/editbuffer.h
deleted file mode 100644 (file)
index 91e2999..0000000
--- a/win32caml/editbuffer.h
+++ /dev/null
@@ -1,47 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Jacob Navia, after Xavier Leroy                          */
-/*                                                                     */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-#ifndef _EDITBUFFER_H_
-#define _EDITBUFFER_H_
-
-// All the below was added by Chris Watford watford@uiuc.edu
-
-typedef struct tagLineList {
-        struct tagLineList     *Next;
-               struct tagLineList      *Prev;
-        char                           *Text;
-} LineList;
-
-typedef struct tagEditBuffer {
-       int                                     LineCount;
-       struct tagLineList      *Lines;
-       BOOL                            isCorrect;
-} EditBuffer;
-
-BOOL           editbuffer_addline                      (EditBuffer* edBuf, char* line);
-BOOL           editbuffer_updateline           (EditBuffer* edBuf, int idx, char* line);
-BOOL           editbuffer_updateoraddline      (EditBuffer* edBuf, int idx, char* line);
-BOOL           editbuffer_removeline           (EditBuffer* edBuf, int idx);
-char*          editbuffer_getasline            (EditBuffer* edBuf);
-char*          editbuffer_getasbuffer          (EditBuffer* edBuf);
-char*          editbuffer_lastline                     (EditBuffer* edBuf);
-EditBuffer*    editbuffer_copy                         (EditBuffer* edBuf);
-void           editbuffer_destroy                      (EditBuffer* edBuf);
-EditBuffer*    editbuffer_new                          (void);
-
-#endif

diff --git a/win32caml/history.c b/win32caml/history.c
deleted file mode 100644 (file)
index 11397ac..0000000
--- a/win32caml/history.c
+++ /dev/null
@@ -1,98 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Jacob Navia, after Xavier Leroy                          */
-/*                                                                     */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-#include "inria.h"
-#include "history.h"
-
-/*------------------------------------------------------------------------
-Procedure:     AddToHistory ID:2
-Author:                   Chris Watford watford@uiuc.edu
-Purpose:       Adds an edit buffer to the history control
-Input:            Pointer to the edit buffer to add
-Output:
-Errors:
---------------------------------------------------------------------------
-Edit History:
-       15 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Complete rewrite
-               - Got it to add the edit buffer to the history
-       17 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added doubly link list support
-------------------------------------------------------------------------*/
-void AddToHistory(EditBuffer *edBuf)
-{
-       StatementHistory *newLine;
-
-       // sanity checks
-       if(edBuf == NULL)
-       {
-               return;
-       } else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) {
-               // fix any possible errors that may come from this
-               edBuf->LineCount = 0;
-               edBuf->Lines = NULL;
-               return;
-       }
-
-       // setup newline and add as the front of the linked list
-       newLine = SafeMalloc(sizeof(StatementHistory));
-       newLine->Next = History;
-       newLine->Prev = NULL;
-       newLine->Statement = edBuf;
-
-       // setup back linking
-       if(History != NULL)
-               History->Prev = newLine;
-
-       // set the history up
-       History = newLine;
-
-       // search for the new history tail
-       for(HistoryTail = (HistoryTail != NULL ? HistoryTail : History); HistoryTail->Next != NULL; HistoryTail = HistoryTail->Next);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     GetHistoryLine ID:2
-Author:                   Chris Watford watford@uiuc.edu
-Purpose:       Returns an entry from the history table
-Input:            Index of the history entry to return
-Output:                   The history entry as a single line
-Errors:
---------------------------------------------------------------------------
-Edit History:
-       15 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Complete rewrite
-       17 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added doubly link list support
-------------------------------------------------------------------------*/
-char *GetHistoryLine(int n)
-{
-       StatementHistory *histentry = History;
-       int i;
-
-       // traverse linked list looking for member n
-       for (i = 0; ((i < n) && (histentry != NULL)); i++, histentry = histentry->Next);
-
-       // figure out what to return
-       if (histentry != NULL)
-       {
-               return editbuffer_getasline(histentry->Statement);
-       } else {
-               return "";
-       }
-}

diff --git a/win32caml/history.h b/win32caml/history.h
deleted file mode 100644 (file)
index a9ba858..0000000
--- a/win32caml/history.h
+++ /dev/null
@@ -1,35 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Jacob Navia, after Xavier Leroy                          */
-/*                                                                     */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-#ifndef _HISTORY_H_
-#define _HISTORY_H_
-
-#include "editbuffer.h"
-
-// Simple linked list for holding the history lines
-typedef struct tagStatementHistory {
-        struct tagStatementHistory     *Next;
-               struct tagStatementHistory      *Prev;
-        EditBuffer                                     *Statement;
-} StatementHistory;
-
-void   AddToHistory    (EditBuffer *edBuf);
-char   *GetHistoryLine (int n);
-static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam);
-
-#endif

diff --git a/win32caml/inria.h b/win32caml/inria.h
deleted file mode 100644 (file)
index 095cbcc..0000000
--- a/win32caml/inria.h
+++ /dev/null
@@ -1,134 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-/*------------------------------------------------------------------------
- Module:        D:\lcc\inria\inria.h
- Author:        Jacob
- Project:
- State:
- Creation Date: June 2001
- Description:   The user interface works as follows:
-                1: At startup it will look for the path to the
-                ocaml interpreter in the registry using the
-                key HKEY_CURRENT_USER\SOFTWARE\ocaml. If not
-                found will prompt the user.
-                2: It will start the ocaml interpreter with
-                its standard output and standard input
-                connected to two pipes in a dedicated thread.
-                3: It will open a window containing an edit
-                field. The output from the interpreter will be
-                shown in the edit field, and the input of the
-                user in the edit field will be sent to the
-                interpreter when the user types return.
-                4: Line editing is provided by moving to the
-                desired line with the arrows, then pressing
-                return; If we aren't in the last input line,
-                the input will be copied to the last line and
-                sent to the interpreter.
-                5: The GUI ensures that when we exit the ocaml
-                interpreter is stopped by sending the
-                character string "#quit;;\nCtrl-Z"
-                6: A history of all lines sent to the interpreter
-                is maintained in a simple linked list. The
-                History dialog box shows that, and allows the
-                user to choose a given input line.
-                7: Memory limits. The edit buffer can be of an
-                arbitrary length, i.e. maybe 7-8MB or more,
-                there are no fixed limits. The History list
-                will always grow too, so memory consumption
-                could be "high" after several days of
-                uninterrupted typing at the keyboard. For that
-                cases it is recommended to stop the GUI and
-                get some sleep...
-                9: The GUI will start a timer, looking 4 times a
-                second if the interpreter has written
-                something in the pipe. This is enough for most
-                applications.
-------------------------------------------------------------------------*/
-#ifndef _INRIA_H_
-#define _INRIA_H_
-
-#include <windows.h>
-#include "editbuffer.h"
-#include "history.h"
-
-#if _MSC_VER <= 1200 && !defined(__MINGW32__)
-#define GetWindowLongPtr GetWindowLong
-#define SetWindowLongPtr SetWindowLong
-#define DWLP_USER DWL_USER
-#define GWLP_WNDPROC GWL_WNDPROC
-#define LONG_PTR DWORD
-#endif
-
-// In this structure should go eventually all global variables scattered
-// through the program.
-typedef struct _programParams {
-        HFONT hFont;                                    // The handle of the current font
-        COLORREF TextColor;                             // The text color
-        char CurrentWorkingDir[MAX_PATH];// The current directory
-} PROGRAM_PARAMS;
-
-//**************** Global variables ***********************
-extern PROGRAM_PARAMS ProgramParams;
-
-extern COLORREF BackColor;                      // The background color
-extern HBRUSH BackgroundBrush;          // A brush built with the background color
-extern char LibDir[];                           // The lib directory
-extern char OcamlPath[];                        // The Path to ocaml.exe
-extern HANDLE hInst;                            // The instance handle for this application
-extern HWND hwndSession;                        // The current session window handle
-extern LOGFONT CurrentFont;                     // The current font characteristics
-extern HWND hwndMain,hwndMDIClient; // Window handles of frame and mdi window
-
-// ***************** Function prototypes ******************
-int WriteToPipe(char *data);            // Writes to the pipe
-int ReadFromPipe(char *data,int len);// Reads from the pipe
-int AskYesOrNo(char *msg);                      //Ditto!
-int BrowseForFile(char *fname,char *path);
-void GotoEOF(void);                                     // Positions the cursor at the end of the text
-void ShowDbgMsg(char *msg);                     // Shows an error message
-void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam);
-int GetOcamlPath(void);                         // Finds where ocaml.exe is
-void ForceRepaint(void);                        // Ditto.
-void AddLineToControl(char *buf);
-void AddStringToControl(char* buf);
-char *GetHistoryLine(int n);            // Gets the nth history line base 1.
-int StartOcaml(void);
-void InterruptOcaml(void);
-int ResetText(void);
-BOOL SendingFullCommand(void);
-void RewriteCurrentEditBuffer(void);
-void RefreshCurrentEditBuffer(void);
-
-// **************** User defined window messages *************
-#define WM_NEWLINE             (WM_USER+6000)
-#define WM_TIMERTICK   (WM_USER+6001)
-#define WM_QUITOCAML   (WM_USER+6002)
-#define WM_SYNTAXERROR (WM_USER+6003)
-#define WM_UNBOUNDVAL  (WM_USER+6004)
-#define WM_ILLEGALCHAR (WM_USER+6005)
-
-// ********************** Structures ***********************
-typedef struct tagPosition {
-        int line;
-        int col;
-} POSITION;
-
-extern void *SafeMalloc(int);
-extern StatementHistory *History; // The root of the history lines
-extern StatementHistory *HistoryTail; // The tail of the history lines
-extern EditBuffer *CurrentEditBuffer; // current edit buffer
-
-#define IDEDITCONTROL 15432
-#endif

diff --git a/win32caml/inriares.h b/win32caml/inriares.h
deleted file mode 100644 (file)
index 2043a37..0000000
--- a/win32caml/inriares.h
+++ /dev/null
@@ -1,48 +0,0 @@
-/* Weditres generated include file. Do NOT edit */
-#define IDD_ABOUT       100
-#define IDM_NEW 200
-#define IDM_OPEN        210
-#define IDM_SAVE        220
-#define IDM_SAVEAS      230
-#define IDM_CLOSE       240
-#define IDM_PRINT       250
-#define IDM_PRINTSU     260
-#define IDM_PRINTPRE    265
-#define IDM_PAGESETUP   267
-#define IDM_EXIT        270
-#define IDM_HISTORY     281
-#define IDM_GC  282
-#define IDCTRLC 283
-#define IDD_HISTORY     300
-#define IDLIST  301
-#define IDM_EDITUNDO    310
-#define IDM_EDITCUT     320
-#define IDM_EDITCOPY    330
-#define IDM_EDITPASTE   340
-#define IDM_EDITCLEAR   350
-#define IDM_EDITDELETE  360
-#define IDM_EDITREPLACE 370
-#define IDM_EDITREDO    380
-#define IDM_WINDOWTILE  410
-#define IDM_WINDOWCASCADE       420
-#define IDM_WINDOWICONS 430
-#define IDM_WINDOWCLOSEALL      440
-#define IDM_PROPERTIES  450
-#define IDM_ABOUT       500
-#define IDM_HELP        510
-#define IDMAINMENU      600
-#define IDM_FIND        700
-#define IDAPPLICON      710
-#define IDI_CHILDICON   800
-#define IDAPPLCURSOR    810
-#define OCAML_ICON      1000
-#define IDS_FILEMENU    2000
-#define IDS_HELPMENU    2010
-#define IDS_SYSMENU     2030
-#define IDM_STATUSBAR   3000
-#define IDM_WINDOWCHILD 3010
-#define ID_TOOLBAR      5000
-#define IDACCEL 10000
-#define IDM_FONT        40002
-#define IDM_COLORTEXT   40004
-#define IDM_BACKCOLOR   40005

diff --git a/win32caml/libgraph.h b/win32caml/libgraph.h
deleted file mode 100644 (file)
index 3bfaff3..0000000
--- a/win32caml/libgraph.h
+++ /dev/null
@@ -1,108 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*            Jacob Navia, after Xavier Leroy                          */
-/*                                                                     */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <windows.h>
-
-struct canvas {
-  int w, h;                     /* Dimensions of the drawable */
-  HWND win;                     /* The drawable itself */
-  HDC gc;                        /* The associated graphics context */
-};
-
-extern HWND grdisplay;     /* The display connection */
-//extern int grscreen;            /* The screen number */
-//extern Colormap grcolormap;     /* The color map */
-//extern struct canvas grwindow;  /* The graphics window */
-//extern struct canvas grbstore;  /* The pixmap used for backing store */
-//extern int grwhite, grblack;    /* Black and white pixels for X */
-//extern int grbackground;        /* Background color for X
-//                                   (used for CAML color -1) */
-extern COLORREF grbackground;
-extern BOOL grdisplay_mode;     /* Display-mode flag */
-extern BOOL grremember_mode;    /* Remember-mode flag */
-extern int grx, gry;            /* Coordinates of the current point */
-extern int grcolor;             /* Current *CAML* drawing color (can be -1) */
-extern HFONT * grfont;          /* Current font */
-
-extern BOOL direct_rgb;
-extern int byte_order;
-extern int bitmap_unit;
-extern int bits_per_pixel;
-
-#define Wcvt(y) (grwindow.height - 1 - (y))
-#define Bcvt(y) (grwindow.height - 1 - (y))
-#define WtoB(y) ((y) + WindowRect.bottom - grwindow.h)
-//#define BtoW(y) ((y) + WindowRect.bottom - grbstore.h)
-
-#define DEFAULT_SCREEN_WIDTH 1024
-#define DEFAULT_SCREEN_HEIGHT 768
-#define BORDER_WIDTH 2
-#define WINDOW_NAME "Caml graphics"
-#define ICON_NAME "Caml graphics"
-#define DEFAULT_EVENT_MASK \
-          (ExposureMask | KeyPressMask | StructureNotifyMask)
-#define DEFAULT_FONT "fixed"
-#define SIZE_QUEUE 256
-
-/* To handle events asynchronously */
-#ifdef HAS_ASYNC_IO
-#define USE_ASYNC_IO
-#define EVENT_SIGNAL SIGIO
-#else
-#ifdef HAS_SETITIMER
-#define USE_INTERVAL_TIMER
-#define EVENT_SIGNAL SIGALRM
-#else
-#define USE_ALARM
-#define EVENT_SIGNAL SIGALRM
-#endif
-#endif
-
-void gr_fail(char *fmt, char *arg);
-void gr_check_open(void);
-unsigned long gr_pixel_rgb(int rgb);
-int gr_rgb_pixel(long unsigned int pixel);
-void gr_enqueue_char(unsigned char c);
-void gr_init_color_cache(void);
-
-// Windows specific definitions
-extern RECT WindowRect;
-extern int grCurrentColor;
-
-typedef struct tagWindow {
-        HDC gc;
-        HDC gcBitmap;
-        HWND hwnd;
-        HBRUSH CurrentBrush;
-        HPEN CurrentPen;
-        DWORD CurrentColor;
-        int width;
-        int height;
-        int grx;
-        int gry;
-        HBITMAP hBitmap;
-        HFONT CurrentFont;
-        int CurrentFontSize;
-        HDC tempDC; // For image operations;
-} GR_WINDOW;
-
-extern GR_WINDOW grwindow;
-HFONT CreationFont(char *name);
-extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown;
-extern HANDLE EventHandle;
-extern int InspectMessages;
-extern MSG msg;
-

diff --git a/win32caml/menu.c b/win32caml/menu.c
deleted file mode 100644 (file)
index 9ab0f5f..0000000
--- a/win32caml/menu.c
+++ /dev/null
@@ -1,830 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <stdio.h>
-#include <windows.h>
-#include <Richedit.h>
-#include "inria.h"
-#include "inriares.h"
-#include "history.h"
-
-LOGFONT CurrentFont;
-int CurrentFontFamily = (FIXED_PITCH | FF_MODERN);
-int CurrentFontStyle;
-char CurrentFontName[64] = "Courier";
-
-/*------------------------------------------------------------------------
- Procedure:     OpenMlFile ID:1
- Purpose:       Opens a file, either a source file (*.ml) or an *.cmo
-                file.
- Input:         A buffer where the name will be stored, and its
-                length
- Output:        The user's choice will be stored in the buffer.
- Errors:        None
-------------------------------------------------------------------------*/
-int OpenMlFile(char *fname,int lenbuf)
-{
-        OPENFILENAME ofn;
-        int r;
-        char *p,defext[5],tmp[512];
-
-        memset(&ofn,0,sizeof(OPENFILENAME));
-        memset(tmp,0,sizeof(tmp));
-        fname[0] = 0;
-        strcpy(tmp,"ocaml sources|*.ml|bytecode object files|*.cmo|All files|*.*");
-        p = tmp;
-        while (*p) {
-                if (*p == '|')
-                        *p = 0;
-                p++;
-        }
-        strcpy(defext,"ml");
-        ofn.lStructSize = sizeof(OPENFILENAME);
-        ofn.hwndOwner = hwndMain;
-        ofn.lpstrFilter = tmp;
-        ofn.nFilterIndex = 1;
-        ofn.hInstance = hInst;
-        ofn.lpstrFile = fname;
-        ofn.lpstrTitle = "Open file";
-        ofn.lpstrInitialDir = LibDir;
-        ofn.nMaxFile = lenbuf;
-        ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES |
-                OFN_HIDEREADONLY |OFN_EXPLORER;
-        r = GetOpenFileName(&ofn);
-        if (r) {
-          /* Replace backslashes by forward slashes in file name */
-          for (p = fname; *p != 0; p++)
-            if (*p == '\\') *p = '/';
-        }
-        return r;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     GetSaveName ID:1
- Purpose:       Get a name to save the current session (Save as menu
-                item)
- Input:         A buffer where the name of the file will be stored,
-                and its length
- Output:        The name of the file choosen by the user will be
-                stored in the buffer
- Errors:        none
-------------------------------------------------------------------------*/
-int GetSaveName(char *fname,int lenbuf)
-{
-        OPENFILENAME ofn;
-        int r;
-        char *p,defext[5],tmp[512];
-
-        memset(&ofn,0,sizeof(OPENFILENAME));
-        memset(tmp,0,sizeof(tmp));
-        fname[0] = 0;
-        strcpy(tmp,"Text files|*.txt");
-        p = tmp;
-        while (*p) {
-                if (*p == '|')
-                        *p = 0;
-                p++;
-        }
-        strcpy(defext,"txt");
-        ofn.lStructSize = sizeof(OPENFILENAME);
-        ofn.hwndOwner = hwndMain;
-        ofn.lpstrFilter = tmp;
-        ofn.nFilterIndex = 1;
-        ofn.hInstance = hInst;
-        ofn.lpstrFile = fname;
-        ofn.lpstrTitle = "Save as";
-        ofn.lpstrInitialDir = LibDir;
-        ofn.nMaxFile = lenbuf;
-        ofn.Flags =  OFN_NOCHANGEDIR | OFN_LONGNAMES |
-                OFN_HIDEREADONLY |OFN_EXPLORER;
-        r = GetSaveFileName(&ofn);
-        if (r == 0)
-                return 0;
-        else return 1;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     GetSaveMLName ID:1
- Purpose:       Get a name to save the current OCaml code to (Save as menu
-                item)
- Input:         A buffer where the name of the file will be stored,
-                and its length
- Output:        The name of the file choosen by the user will be
-                stored in the buffer
- Errors:        none
-------------------------------------------------------------------------*/
-int GetSaveMLName(char *fname, int lenbuf)
-{
-        OPENFILENAME ofn;
-        int r;
-        char *p,defext[5],tmp[512];
-
-        memset(&ofn,0,sizeof(OPENFILENAME));
-        memset(tmp,0,sizeof(tmp));
-        fname[0] = 0;
-        strcpy(tmp,"OCaml Source Files|*.ml");
-        p = tmp;
-        while (*p) {
-                if (*p == '|')
-                        *p = 0;
-                p++;
-        }
-        strcpy(defext,"ml");
-        ofn.lStructSize = sizeof(OPENFILENAME);
-        ofn.hwndOwner = hwndMain;
-        ofn.lpstrFilter = tmp;
-        ofn.nFilterIndex = 1;
-        ofn.hInstance = hInst;
-        ofn.lpstrFile = fname;
-        ofn.lpstrTitle = "Save as";
-        ofn.lpstrInitialDir = LibDir;
-        ofn.nMaxFile = lenbuf;
-        ofn.Flags =  OFN_NOCHANGEDIR | OFN_LONGNAMES |
-                OFN_HIDEREADONLY |OFN_EXPLORER;
-        r = GetSaveFileName(&ofn);
-        if (r == 0)
-                return 0;
-        else return 1;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     BrowseForFile ID:1
- Purpose:       Let's the user browse for a certain kind of file.
-                Currently this is only used when browsing for
-                ocaml.exe.
- Input:         The name of the file to browse for, and the path
-                where the user's choice will be stored.
- Output:        1 if user choosed a path, zero otherwise
- Errors:        None
-------------------------------------------------------------------------*/
-int BrowseForFile(char *fname,char *path)
-{
-        OPENFILENAME ofn;
-        char *p,tmp[512],browsefor[512];
-        int r;
-
-        memset(tmp,0,sizeof(tmp));
-        strncpy(tmp,fname,sizeof(tmp)-1);
-        p = tmp;
-        while (*p) {
-                if (*p == '|')
-                        *p = 0;
-                p++;
-        }
-        memset(&ofn,0,sizeof(OPENFILENAME));
-        ofn.lpstrFilter = tmp;
-        ofn.nFilterIndex = 1;
-        ofn.lStructSize = sizeof(OPENFILENAME);
-        ofn.hwndOwner = hwndMain;
-        ofn.hInstance = hInst;
-        ofn.lpstrFilter = tmp;
-        ofn.lpstrFile = path;
-        wsprintf(browsefor,"Open %s",fname);
-        ofn.lpstrTitle = browsefor;
-        ofn.lpstrInitialDir = "c:\\";
-        ofn.nMaxFile = MAX_PATH;
-        ofn.Flags = OFN_PATHMUSTEXIST | OFN_NOCHANGEDIR | OFN_LONGNAMES |
-                OFN_HIDEREADONLY |OFN_EXPLORER;
-        r = GetOpenFileName(&ofn);
-        if (r == 0)
-                return 0;
-        else return 1;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     CallChangeFont ID:1
- Purpose:       Calls the standard windows font change dialog. If the
-                user validates a font, it will destroy the current
-                font, and recreate a new font with the given
-                parameters.
- Input:         The calling window handle
- Output:        Zero if the user cancelled, 1 otherwise.
- Errors:        None
-------------------------------------------------------------------------*/
-static int CallChangeFont(HWND hwnd)
-{
-        LOGFONT lf;
-        CHOOSEFONT cf;
-        int r;
-        HWND hwndChild;
-
-        memset(&cf, 0, sizeof(CHOOSEFONT));
-        memcpy(&lf, &CurrentFont, sizeof(LOGFONT));
-        cf.lStructSize = sizeof(CHOOSEFONT);
-        cf.hwndOwner = hwnd;
-        cf.lpLogFont = &lf;
-        cf.Flags = CF_SCREENFONTS | CF_EFFECTS | CF_APPLY | CF_INITTOLOGFONTSTRUCT;
-        cf.nFontType = SCREEN_FONTTYPE;
-        r = ChooseFont(&cf);
-        if (!r)
-                return (0);
-        DeleteObject(ProgramParams.hFont);
-        memcpy(&CurrentFont, &lf, sizeof(LOGFONT));
-        ProgramParams.hFont = CreateFontIndirect(&CurrentFont);
-        strcpy(CurrentFontName, CurrentFont.lfFaceName);
-        CurrentFontFamily = lf.lfPitchAndFamily;
-        CurrentFontStyle = lf.lfWeight;
-    hwndChild = (HWND) GetWindowLongPtr(hwndSession, DWLP_USER);
-        SendMessage(hwndChild,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
-        ForceRepaint();
-        return (1);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     CallDlgProc ID:1
- Purpose:       Calls a dialog box procedure
- Input:         The function to call, and the numerical ID of the
-                resource where the dialog box is stored
- Output:        Returns the result of the dialog box.
- Errors:        None
-------------------------------------------------------------------------*/
-int CallDlgProc(BOOL (CALLBACK *fn)(HWND,UINT,WPARAM,LPARAM), int id)
-{
-   int result;
-
-   result = DialogBoxParam(hInst, MAKEINTRESOURCE(id), GetActiveWindow(),
-                        fn, 0);
-   return result;
-}
-
-
-/*------------------------------------------------------------------------
- Procedure:     CallChangeColor ID:1
- Purpose:       Calls the standard color dialog of windows, starting
-                with the given color reference. The result is the
-                same as the input if the user cancels, or another
-                color if the user validates another one.
- Input:         The starting color
- Output:        The color the user has choosen.
- Errors:        None
-------------------------------------------------------------------------*/
-static COLORREF CallChangeColor(COLORREF InitialColor)
-{
-        CHOOSECOLOR CC;
-        COLORREF CustColors[16];
-        int r, g, b, i;
-        memset(&CC, 0, sizeof(CHOOSECOLOR));
-        r = g = b = 0;
-        for (i = 0; i < 16; i++) {
-                CustColors[i] = RGB(r, g, b);
-                if (r < 255)
-                        r += 127;
-                else if (g < 255)
-                        g += 127;
-                else if (b < 255)
-                        g += 127;
-        }
-        CC.lStructSize = sizeof(CHOOSECOLOR);
-        CC.hwndOwner = hwndMain;
-        CC.hInstance = hInst;
-        CC.rgbResult = InitialColor;
-        CC.lpCustColors = CustColors;
-        CC.Flags = CC_RGBINIT;
-        if (!ChooseColor(&CC))
-                return (InitialColor);
-        return (CC.rgbResult);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     CallPrintSetup ID:1
- Purpose:       Calls the printer setup dialog. Currently it is not
-                connected to the rest of the software, since printing
-                is not done yet
- Input:         None
- Output:        1 if OK, 0, user cancelled
- Errors:        None
-------------------------------------------------------------------------*/
-static int CallPrintSetup(void)
-{
-        PAGESETUPDLG sd;
-        int r;
-
-        memset(&sd,0,sizeof(sd));
-        sd.lStructSize = sizeof(sd);
-        sd.Flags = PSD_RETURNDEFAULT;
-        r = PageSetupDlg(&sd);
-        if (!r)
-                return 0;
-        sd.Flags = 0;
-        r = PageSetupDlg(&sd);
-        return r;
-}
-
-
-/*------------------------------------------------------------------------
- Procedure:     Undo ID:1
- Purpose:       Send an UNDO command to the edit field.
- Input:         The parent window of the control
- Output:        None
- Errors:        None
-------------------------------------------------------------------------*/
-void Undo(HWND hwnd)
-{
-        HWND hEdit;
-
-        hEdit = (HWND)GetWindowLongPtr(hwnd,DWLP_USER);
-        SendMessage(hEdit,EM_UNDO,0,0);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     ForceRepaint ID:1
- Purpose:       Forces a complete redraw of the edit control of the
-                current session.
- Input:         None
- Output:        None
- Errors:        None
-------------------------------------------------------------------------*/
-void ForceRepaint(void)
-{
-        HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-        InvalidateRect(hwndEdit,NULL,1);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     Add_Char_To_Queue ID:1
- Purpose:       Puts a character onto the buffer
- Input:         The char to be added
- Output:        None
- Errors:
-------------------------------------------------------------------------*/
-static void Add_Char_To_Queue(int c)
-{
-        HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-        SendMessage(hwndEdit,WM_CHAR,c,1);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     AddLineToControl ID:1
- Purpose:       It will ad the given text at the end of the edit
-                control, then it will send a return character to it.
-                This simulates user input. The history will not be
-                modified by this procedure.
- Input:         The text to be added
- Output:        None
- Errors:        If the line is empty, nothing will be done
-------------------------------------------------------------------------*/
-void AddLineToControl(char *buf)
-{
-        HWND hEditCtrl;
-
-        if (*buf == 0)
-                return;
-
-        hEditCtrl = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-
-        GotoEOF();
-
-        SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)buf);
-        SendMessage(hEditCtrl,WM_CHAR,'\r',0);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     AddStringToControl ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       It will ad the given text at the end of the edit
-                control. This simulates user input. The history will not
-                               be modified by this procedure.
- Input:         The text to be added
- Output:        None
- Errors:        If the line is empty, nothing will be done
---------------------------------------------------------------------------
-Edit History:
-       16 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Basically this is AddLineToControl, but without appending a
-                 newline
-------------------------------------------------------------------------*/
-void AddStringToControl(char* buf)
-{
-        HWND hEditCtrl;
-
-               if(buf == NULL)
-                       return;
-
-        if((*buf) == 0)
-            return;
-
-        hEditCtrl = (HWND)GetWindowLongPtr(hwndSession, DWLP_USER);
-        GotoEOF();
-
-        SendMessage(hEditCtrl ,EM_REPLACESEL, (WPARAM)FALSE, (LPARAM)buf);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     AboutDlgProc ID:1
- Purpose:       Shows the "About" dialog box
- Input:
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static BOOL CALLBACK AboutDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
-{
-        if (message == WM_CLOSE)
-                EndDialog(hDlg,1);
-        return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     HistoryDlgProc ID:1
- Purpose:       Shows the history of the session. Only input lines
-                are shown. A double click in a line will make this
-                dialog box procedure return the index of the selected
-                line (1 based). If the windows is closed (what is
-                equivalent to cancel), the return value is zero.
- Input:         Normal windows callback
- Output:
- Errors:
---------------------------------------------------------------------------
-Edit History:
-       15 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added support for my StatementHistory structure
-               - Added the ability to export it as its exact entry, rather than
-                 just a 1 liner
-------------------------------------------------------------------------*/
-static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam)
-{
-        StatementHistory *histentry;
-        int idx;
-        RECT rc;
-
-        switch (message) {
-                case WM_INITDIALOG:
-                        SendDlgItemMessage(hDlg,IDLIST,WM_SETFONT,(WPARAM)ProgramParams.hFont,0);
-                        histentry = History; // get our statement history object
-                        idx = 0;
-
-                                               // loop through each history entry adding it to the dialog
-                        while (histentry != NULL) {
-                                SendDlgItemMessage(hDlg,IDLIST,LB_INSERTSTRING,0,(LPARAM)editbuffer_getasline(histentry->Statement));
-                                SendDlgItemMessage(hDlg,IDLIST,LB_SETITEMDATA,0,(LPARAM)idx);
-                                histentry = histentry->Next;
-                                idx++;
-                        }
-
-                        SendDlgItemMessage(hDlg,IDLIST,LB_SETCURSEL,(LPARAM)idx-1,0);
-                        return 1;
-                case WM_COMMAND:
-                        switch(LOWORD(wParam)) {
-                                case IDLIST:
-                                        switch(HIWORD(wParam)) {
-                                                case LBN_DBLCLK:
-                                                        idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETCURSEL,0,0);
-                                                        if (idx == LB_ERR)
-                                                                break;
-                                                        idx = SendDlgItemMessage(hDlg,IDLIST,LB_GETITEMDATA,idx,0);
-                                                        EndDialog(hDlg,idx+1);
-                                                        return 1;
-                                        }
-                                        break;
-                        }
-                        break;
-                case WM_SIZE:
-                        GetClientRect(hDlg,&rc);
-                        MoveWindow(GetDlgItem(hDlg,IDLIST),0,0,rc.right,rc.bottom,1);
-                        break;
-
-                case WM_CLOSE:
-                        EndDialog(hDlg,0);
-                        break;
-        }
-        return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     SaveText ID:1
- Purpose:       Saves the contents of the session transcript. It will
-                loop for each line and write it to the specified file
- Input:         The name of the file where the session will be saved
- Output:        The session is saved
- Errors:        If it can't open the file for writing it will show an
-                error box
---------------------------------------------------------------------------
- Edit History:
-       06 Oct  2003 - Chris Watford watford@uiuc.edu
-               - Corrected wsprintf error
-------------------------------------------------------------------------*/
-static void SaveText(char *fname)
-{
-        int i,len;
-        HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-        int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-        FILE *f;
-        char *buf = SafeMalloc(8192);
-
-        f = fopen(fname,"wb");
-        if (f == NULL)
-               {
-                       // corrected error using wsprintf
-            wsprintf(buf, "Impossible to open %s for writing", fname);
-
-            ShowDbgMsg(buf);
-            return;
-        }
-
-        for (i = 0; i < linesCount; i++)
-               {
-                *(unsigned short *)buf = 8100;
-                len = SendMessage(hEdit, EM_GETLINE, i, (LPARAM)buf);
-                buf[len] = '\0';
-                               fprintf(f, "%s\r\n", buf+1);
-                //fwrite(buf,1,len+2,f);
-        }
-
-        fclose(f);
-        free(buf);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     SaveML ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Saves the ML source to a file, commenting out functions
-                               that contained errors
- Input:         The name of the file where the session will be saved
- Output:        The session is saved
- Errors:        If it can't open the file for writing it will show an
-                error box
-------------------------------------------------------------------------*/
-static void SaveML(char *fname)
-{
-        FILE *f;
-        char *buf = SafeMalloc(8192);
-
-        f = fopen(fname, "wb");
-
-        if(f == NULL)
-               {
-                wsprintf(buf, "Impossible to open %s for writing", fname);
-                ShowDbgMsg(buf);
-                return;
-        }
-
-               fprintf(f, "(* %s *)\r\n\r\n", fname);
-
-               if(History != NULL)
-               {
-                       StatementHistory *h = NULL;
-                       EditBuffer *stmt = NULL;
-
-                       // get to the end
-                       for(h = History; h->Next != NULL; h = h->Next);
-
-                       // go back :(
-                       // this is NOT the fastest method, BUT this is the easiest
-                       // on the subsystem
-                       for(; h != NULL; h = h->Prev)
-                       {
-                               stmt = h->Statement;
-
-                               if(stmt != NULL)
-                               {
-                                       // comment out incorrect lines
-                                       if(stmt->isCorrect)
-                                       {
-                                               char *buff = editbuffer_getasbuffer(stmt);
-                                               fprintf(f, "%s\r\n", buff);
-                                               free(buff);
-                                       } else {
-                                               char *buff = editbuffer_getasbuffer(stmt);
-                                               fprintf(f, "(* Syntax Error or Unbound Value\r\n%s\r\n *)\r\n", buff);
-                                               free(buff);
-                                       }
-                               }
-
-                               fprintf(f, "\r\n");
-                       }
-               }
-
-        fclose(f);
-        free(buf);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     Add_Clipboard_To_Queue ID:1
- Author:               Chris Watford watford@uiuc.edu
- Purpose:       Adds the clipboard text to the control
- Input:
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-       16 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added method to update edit buffer with paste contents
-------------------------------------------------------------------------*/
-static void Add_Clipboard_To_Queue(void)
-{
-    if (IsClipboardFormatAvailable(CF_TEXT) && OpenClipboard(hwndMain))
-    {
-        HANDLE hClipData = GetClipboardData(CF_TEXT);
-
-        if (hClipData != NULL)
-        {
-            char *str = GlobalLock(hClipData);
-
-            if (str != NULL)
-                       {
-                while ((*str) != 0)
-                {
-                    if (*str != '\r')
-                        Add_Char_To_Queue(*str);
-
-                    str++;
-                }
-
-                               // added to fix odd errors
-                               RefreshCurrentEditBuffer();
-                       }
-
-            GlobalUnlock(hClipData);
-        }
-
-        CloseClipboard();
-    }
-}
-
-/*------------------------------------------------------------------------
- Procedure:     CopyToClipboard ID:1
- Purpose:       Copies text to the clipboard
- Input:                        Window with the edit control
- Output:
- Errors:
-------------------------------------------------------------------------*/
-static void CopyToClipboard(HWND hwnd)
-{
-        HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-        SendMessage(hwndEdit,WM_COPY,0,0);
-}
-
-/*------------------------------------------------------------------------
- Procedure:     ResetText ID:1
- Purpose:       Resets the text? I'm not really sure
- Input:
- Output:               Always returns 0
- Errors:
-------------------------------------------------------------------------*/
-int ResetText(void)
-{
-        HWND hwndEdit = (HWND) GetWindowLongPtr(hwndSession,DWLP_USER);
-        TEXTRANGE cr;
-        int len = SendMessage(hwndEdit,WM_GETTEXTLENGTH,0,0);
-        char *tmp = malloc(len+10),*p;
-
-        memset(tmp,0,len+10);
-        cr.chrg.cpMin = 0;
-        cr.chrg.cpMax = -1;
-        cr.lpstrText = tmp;
-        SendMessage(hwndEdit,EM_GETTEXTRANGE,0,(LPARAM)&cr);
-        p = tmp+len/2;
-        while (*p && *p != '\r')
-                p++;
-        SendMessage(hwndEdit,EM_SETSEL,0,(LPARAM)-1);
-        SendMessage(hwndEdit,EM_REPLACESEL,0,(LPARAM)p);
-        InvalidateRect(hwndEdit,0,1);
-        free(tmp);
-        return 0;
-}
-
-/*------------------------------------------------------------------------
- Procedure:     HandleCommand ID:1
- Purpose:       Handles all menu commands.
- Input:
- Output:
- Errors:
---------------------------------------------------------------------------
- Edit History:
-       06 Oct  2003 - Chris Watford watford@uiuc.edu
-               - Removed entries that crashed OCaml
-               - Removed useless entries
-               - Added Save ML and Save Transcript
-------------------------------------------------------------------------*/
-void HandleCommand(HWND hwnd, WPARAM wParam,LPARAM lParam)
-{
-        char *fname;
-        int r;
-
-        switch(LOWORD(wParam)) {
-                case IDM_OPEN:
-                        fname = SafeMalloc(512);
-                        if (OpenMlFile(fname,512)) {
-                                char *buf = SafeMalloc(512);
-                                char *p = strrchr(fname,'.');
-                                if (p && !stricmp(p,".ml")) {
-                                        wsprintf(buf, "#use \"%s\";;", fname);
-                                        AddLineToControl(buf);
-                                }
-                                else if (p && !stricmp(p,".cmo")) {
-                                        wsprintf(buf, "#load \"%s\";;", fname);
-                                        AddLineToControl(buf);
-                                }
-                                free(buf);
-                        }
-                        free(fname);
-                        break;
-                case IDM_GC:
-                        AddLineToControl("Gc.full_major();;");
-                        break;
-                case IDCTRLC:
-                        InterruptOcaml();
-                        break;
-                case IDM_EDITPASTE:
-                        Add_Clipboard_To_Queue();
-                        break;
-                case IDM_EDITCOPY:
-                        CopyToClipboard(hwnd);
-                        break;
-
-                               // updated to save a transcript
-                case IDM_SAVEAS:
-                        fname = SafeMalloc(512);
-                        if (GetSaveName(fname,512)) {
-                                SaveText(fname);
-                        }
-                        free(fname);
-                        break;
-
-                               // updated to save an ML file
-                               case IDM_SAVE:
-                        fname = SafeMalloc(512);
-                        if (GetSaveMLName(fname,512))
-                                               {
-                                SaveML(fname);
-                        }
-                        free(fname);
-                        break;
-
-                               // updated to work with new history system
-                case IDM_HISTORY:
-                        r = CallDlgProc(HistoryDlgProc,IDD_HISTORY);
-
-                        if (r)
-                                               {
-                                AddLineToControl(GetHistoryLine(r-1));
-                        }
-                        break;
-
-                case IDM_PRINTSU:
-                                               // Removed by Chris Watford
-                                               // seems to die
-                        // CallPrintSetup();
-                        break;
-
-                case IDM_FONT:
-                        CallChangeFont(hwndMain);
-                        break;
-                case IDM_COLORTEXT:
-                        ProgramParams.TextColor = CallChangeColor(ProgramParams.TextColor);
-                        ForceRepaint();
-                        break;
-                case IDM_BACKCOLOR:
-                        BackColor = CallChangeColor(BackColor);
-                        DeleteObject(BackgroundBrush);
-                        BackgroundBrush = CreateSolidBrush(BackColor);
-                        ForceRepaint();
-                        break;
-                case IDM_EDITUNDO:
-                        Undo(hwnd);
-                        break;
-
-                               /* Removed, really not very useful in this IDE
-                case IDM_WINDOWTILE:
-                        SendMessage(hwndMDIClient,WM_MDITILE,0,0);
-                        break;
-                case IDM_WINDOWCASCADE:
-                        SendMessage(hwndMDIClient,WM_MDICASCADE,0,0);
-                        break;
-                case IDM_WINDOWICONS:
-                        SendMessage(hwndMDIClient,WM_MDIICONARRANGE,0,0);
-                        break;
-                               */
-
-                case IDM_EXIT:
-                        PostMessage(hwnd,WM_CLOSE,0,0);
-                        break;
-                case IDM_ABOUT:
-                        CallDlgProc(AboutDlgProc,IDD_ABOUT);
-                        break;
-                default:
-                        if (LOWORD(wParam) >= IDEDITCONTROL && LOWORD(wParam) < IDEDITCONTROL+5) {
-                                switch (HIWORD(wParam)) {
-                                        case EN_ERRSPACE:
-                                                ResetText();
-                                                break;
-                                }
-                        }
-                        break;
-        }
-}

diff --git a/win32caml/ocaml.c b/win32caml/ocaml.c
deleted file mode 100644 (file)
index 2a2e04a..0000000
--- a/win32caml/ocaml.c
+++ /dev/null
@@ -1,1599 +0,0 @@
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-/* $Id$ */
-
-/*@@ Wedit generated application. Written Sat Jun 02 18:22:38 2001
-@@header: D:\lcc\inria\inriares.h
-@@resources: D:\lcc\inria\inria.rc
-Do not edit outside the indicated areas */
-/*<---------------------------------------------------------------------->*/
-
-#include <stdio.h>
-#include <windows.h>
-#include <windowsx.h>
-#include <commctrl.h>
-#include <string.h>
-#include <direct.h>
-#include <Richedit.h>
-#include "inriares.h"
-#include "inria.h"
-
-#define VK_BACKSPACE    0x108
-
-/*<---------------------------------------------------------------------->*/
-int EditControls = IDEDITCONTROL;
-static WNDPROC lpEProc;
-static char lineBuffer[1024*32];
-int ReadToLineBuffer(void);
-int AddLineBuffer(void);
-static int busy;
-static DWORD TimerId;
-POSITION LastPromptPosition;
-char LibDir[512];
-char OcamlPath[512];
-HBRUSH BackgroundBrush;
-COLORREF BackColor = RGB(255,255,255);
-PROGRAM_PARAMS ProgramParams;
-StatementHistory *History = NULL;
-StatementHistory *HistoryTail = NULL;
-StatementHistory *historyEntry = NULL;
-EditBuffer *CurrentEditBuffer = NULL; // current edit buffer
-
-/*<----------------- global variables --------------------------------------->*/
-HANDLE hInst;           // Instance handle
-HWND hwndMain;          //Main window handle
-HWND hwndSession;
-HWND hwndMDIClient;             //Mdi client window handle
-static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam);
-static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam);
-PROCESS_INFORMATION pi;
-HWND  hWndStatusbar;
-
-/*------------------------------------------------------------------------
-Procedure:     UpdateStatusBar ID:1
-Purpose:       Updates the statusbar control with the appropiate
-text
-Input:         lpszStatusString: Charactar string that will be shown
-partNumber: index of the status bar part number.
-displayFlags: Decoration flags
-Output:        none
-Errors:        none
-
-------------------------------------------------------------------------*/
-void UpdateStatusBar(LPSTR lpszStatusString, WORD partNumber, WORD displayFlags)
-{
-       SendMessage(hWndStatusbar,
-               SB_SETTEXT,
-               partNumber | displayFlags,
-               (LPARAM)lpszStatusString);
-}
-
-
-/*------------------------------------------------------------------------
-Procedure:     MsgMenuSelect ID:1
-Purpose:       Shows in the status bar a descriptive explaation of
-the purpose of each menu item.The message
-WM_MENUSELECT is sent when the user starts browsing
-the menu for each menu item where the mouse passes.
-Input:         Standard windows.
-Output:        The string from the resources string table is shown
-Errors:        If the string is not found nothing will be shown.
-------------------------------------------------------------------------*/
-LRESULT MsgMenuSelect(HWND hwnd, UINT uMessage, WPARAM wparam, LPARAM lparam)
-{
-       static char szBuffer[256];
-       UINT   nStringID = 0;
-       UINT   fuFlags = GET_WM_MENUSELECT_FLAGS(wparam, lparam) & 0xffff;
-       UINT   uCmd    = GET_WM_MENUSELECT_CMD(wparam, lparam);
-       HMENU  hMenu   = GET_WM_MENUSELECT_HMENU(wparam, lparam);
-
-       szBuffer[0] = 0;                            // First reset the buffer
-       if (fuFlags == 0xffff && hMenu == NULL)     // Menu has been closed
-               nStringID = 0;
-
-       else if (fuFlags & MFT_SEPARATOR)           // Ignore separators
-               nStringID = 0;
-
-       else if (fuFlags & MF_POPUP)                // Popup menu
-       {
-               if (fuFlags & MF_SYSMENU)               // System menu
-                       nStringID = IDS_SYSMENU;
-               else
-                       // Get string ID for popup menu from idPopup array.
-                       nStringID = 0;
-       }  // for MF_POPUP
-       else                                        // Must be a command item
-               nStringID = uCmd;                       // String ID == Command ID
-
-       // Load the string if we have an ID
-       if (0 != nStringID)
-               LoadString(hInst, nStringID, szBuffer, sizeof(szBuffer));
-       // Finally... send the string to the status bar
-       UpdateStatusBar(szBuffer, 0, 0);
-       return 0;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     TimerProc ID:1
-Purpose:       This procedure will be called by windows about 4
-times a second. It will just send a message to the
-mdi child window to look at the pipe.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static VOID CALLBACK TimerProc(HWND hwnd, UINT uMsg, UINT idEvent, DWORD dwTime)
-{
-       SendMessage(hwndSession, WM_TIMERTICK, 0, 0);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     InitializeStatusBar ID:1
-Purpose:       Initialize the status bar
-Input:         hwndParent: the parent window
-nrOfParts: The status bar can contain more than one
-part. What is difficult, is to figure out how this
-should be drawn. So, for the time being only one is
-being used...
-Output:        The status bar is created
-Errors:
-------------------------------------------------------------------------*/
-void InitializeStatusBar(HWND hwndParent,int nrOfParts)
-{
-       const int cSpaceInBetween = 8;
-       int   ptArray[40];   // Array defining the number of parts/sections
-       RECT  rect;
-       HDC   hDC;
-
-       /* * Fill in the ptArray...  */
-
-       hDC = GetDC(hwndParent);
-       GetClientRect(hwndParent, &rect);
-
-       ptArray[nrOfParts-1] = rect.right;
-       //---TODO--- Add code to calculate the size of each part of the status
-       // bar here.
-
-       ReleaseDC(hwndParent, hDC);
-       SendMessage(hWndStatusbar,
-               SB_SETPARTS,
-               nrOfParts,
-               (LPARAM)(LPINT)ptArray);
-
-       UpdateStatusBar("Ready", 0, 0);
-}
-
-
-/*------------------------------------------------------------------------
-Procedure:     CreateSBar ID:1
-Purpose:       Calls CreateStatusWindow to create the status bar
-Input:         hwndParent: the parent window
-initial text: the initial contents of the status bar
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static BOOL CreateSBar(HWND hwndParent,char *initialText,int nrOfParts)
-{
-       hWndStatusbar = CreateStatusWindow(WS_CHILD | WS_VISIBLE | WS_BORDER|SBARS_SIZEGRIP,
-               initialText,
-               hwndParent,
-               IDM_STATUSBAR);
-       if(hWndStatusbar)
-       {
-               InitializeStatusBar(hwndParent,nrOfParts);
-               return TRUE;
-       }
-
-       return FALSE;
-}
-/*------------------------------------------------------------------------
-Procedure:     InitApplication ID:1
-Purpose:       Registers two window classes: the "inria" window
-class with the main window, and the mdi child
-window's window class.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static BOOL InitApplication(void)
-{
-       WNDCLASS wc;
-
-       memset(&wc,0,sizeof(WNDCLASS));
-       wc.style = CS_HREDRAW|CS_VREDRAW |CS_DBLCLKS ;
-       wc.lpfnWndProc = (WNDPROC)MainWndProc;
-       wc.hInstance = hInst;
-       wc.hbrBackground = (HBRUSH)(COLOR_WINDOW+1);
-       wc.lpszClassName = "inriaWndClass";
-       wc.lpszMenuName = MAKEINTRESOURCE(IDMAINMENU);
-       wc.hCursor = LoadCursor(NULL,IDC_ARROW);
-       wc.hIcon = LoadIcon(hInst,MAKEINTRESOURCE(OCAML_ICON));
-       if (!RegisterClass(&wc))
-               return 0;
-       wc.style         = 0;
-       wc.lpfnWndProc   = (WNDPROC)MdiChildWndProc;
-       wc.cbClsExtra    = 0;
-       wc.cbWndExtra    = 20;
-       wc.hInstance     = hInst;                      // Owner of this class
-       wc.hIcon         = LoadIcon(hInst, MAKEINTRESOURCE(OCAML_ICON));
-       wc.hCursor       = LoadCursor(NULL, IDC_ARROW);
-       wc.hbrBackground = (HBRUSH)(COLOR_WINDOW + 1); // Default color
-       wc.lpszMenuName  = NULL;
-       wc.lpszClassName = "MdiChildWndClass";
-       if (!RegisterClass((LPWNDCLASS)&wc))
-               return FALSE;
-       return 1;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     CreateinriaWndClassWnd ID:1
-Purpose:       Creates the main window
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-HWND CreateinriaWndClassWnd(void)
-{
-       return CreateWindow("inriaWndClass","OCamlWinPlus v1.9RC4",
-               WS_MINIMIZEBOX|WS_VISIBLE|WS_CLIPSIBLINGS|WS_CLIPCHILDREN|WS_MAXIMIZEBOX|WS_CAPTION|WS_BORDER|WS_SYSMENU|WS_THICKFRAME,
-               CW_USEDEFAULT,0,CW_USEDEFAULT,0,
-               NULL,
-               NULL,
-               hInst,
-               NULL);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     MDICmdFileNew ID:1
-Purpose:       Creates a new session window. Note that multiple
-windows with multiple sessions are possible.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static HWND MDICmdFileNew(char *title, int show)
-{
-       HWND  hwndChild;
-       char  rgch[150];
-       static int cUntitled;
-       MDICREATESTRUCT mcs;
-
-       if (title == NULL)
-               wsprintf(rgch,"Session%d", cUntitled++);
-       else {
-               strncpy(rgch,title,149);
-               rgch[149] = 0;
-       }
-
-       // Create the MDI child window
-
-       mcs.szClass = "MdiChildWndClass";      // window class name
-       mcs.szTitle = rgch;             // window title
-       mcs.hOwner  = hInst;            // owner
-       mcs.x       = CW_USEDEFAULT;    // x position
-       mcs.y       = CW_USEDEFAULT;    // y position
-       mcs.cx      = CW_USEDEFAULT;    // width
-       mcs.cy      = CW_USEDEFAULT;    // height
-       mcs.style   = 0;                // window style
-       mcs.lParam  = 0;                // lparam
-
-       hwndChild = (HWND) SendMessage(hwndMDIClient,
-               WM_MDICREATE,
-               0,
-               (LPARAM)(LPMDICREATESTRUCT) &mcs);
-
-       if (hwndChild != NULL && show)
-               ShowWindow(hwndChild, SW_SHOW);
-
-       return hwndChild;
-}
-static HWND CreateMdiClient(HWND hwndparent)
-{
-       CLIENTCREATESTRUCT ccs = {0};
-       HWND hwndMDIClient;
-       int icount = GetMenuItemCount(GetMenu(hwndparent));
-
-       // Find window menu where children will be listed
-       ccs.hWindowMenu  = GetSubMenu(GetMenu(hwndparent), icount-2);
-       ccs.idFirstChild = IDM_WINDOWCHILD;
-
-       // Create the MDI client filling the client area
-       hwndMDIClient = CreateWindow("mdiclient",
-               NULL,
-               WS_CHILD | WS_CLIPCHILDREN | WS_VSCROLL |
-               WS_HSCROLL,
-               0, 0, 0, 0,
-               hwndparent,
-               (HMENU)0xCAC,
-               hInst,
-               (LPVOID)&ccs);
-
-       ShowWindow(hwndMDIClient, SW_SHOW);
-
-       return hwndMDIClient;
-}
-
-void GotoEOF(void)
-{
-       HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-       int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-       int lineindex = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0);
-       int lastLineLength = SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0);
-
-       lineindex += lastLineLength;
-       SendMessage(hEdit,EM_SETSEL,lineindex,lineindex);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     GotoPrompt ID:1
-Author:                   Chris Watford watford@uiuc.edu
-Purpose:       Puts the cursor on the prompt line right after the '# '
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-void GotoPrompt(void)
-{
-       HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-       int lineindex = SendMessage(hEdit,EM_LINEINDEX,LastPromptPosition.line,0)+2;
-       SendMessage(hEdit,EM_SETSEL,lineindex,lineindex);
-}
-
-int GetCurLineIndex(HWND hEdit)
-{
-       return SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
-}
-
-int GetNumberOfLines(HWND hEdit)
-{
-       return SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-}
-
-static int GetWordUnderCursor(HWND hwndEditControl,char *buf,int len)
-{
-       char *line,*p,*pstart,*pend;
-       int lineidx,start,end,length,offset,cursorpos,startingChar;
-
-       SendMessage(hwndEditControl,EM_GETSEL,(WPARAM)&start,(LPARAM)&end);
-       lineidx = SendMessage(hwndEditControl,EM_EXLINEFROMCHAR,0,start);
-       startingChar = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
-       start -= startingChar;
-       end -= startingChar;
-       lineidx = SendMessage(hwndEditControl,EM_LINEFROMCHAR,start,0);
-       length = SendMessage(hwndEditControl,EM_LINELENGTH,lineidx,0);
-       offset = SendMessage(hwndEditControl,EM_LINEINDEX,lineidx,0);
-       line = SafeMalloc(length+1);
-       memset(line,0,length+1);
-       *(unsigned short *)line = length;
-       SendMessage(hwndEditControl,EM_GETLINE,lineidx,(LPARAM)line);
-       cursorpos = start-offset;
-       p = line + cursorpos;
-       pstart = p;
-       while (*pstart
-               && *pstart != ' '
-               && *pstart != '\t'
-               && *pstart != '('
-               && pstart > line)
-               pstart--;
-       pend = p;
-       while (*pend
-               && *pend != ' '
-               && *pend != '\t'
-               && *pend != '('
-               && pend < line + length)
-               pend++;
-       if (*pstart == ' ' || *pstart == '\t')
-               pstart++;
-       if (*pend == ' ' || *pend == '\t')
-               pend--;
-       memcpy(buf,pstart,1+pend-pstart);
-       buf[pend-pstart] = 0;
-       free(line);
-       return 1;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     GetLastLine ID:1
-Purpose:       Gets the data in the line containing the cursor to
-                          the interpreter.
-Input:         The edit control window handle
-Output:        None explicit
-Errors:        None
-------------------------------------------------------------------------*/
-char* GetLastLine(HWND hEdit)
-{
-       int curline = GetCurLineIndex(hEdit);
-       char *linebuffer = (char*)SafeMalloc(2048*sizeof(char));
-       int n;
-       int linescount = GetNumberOfLines(hEdit);
-
-       *(unsigned short *)linebuffer = 2047;
-       n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer);
-
-       if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') {
-               n -= 2;
-               memmove(linebuffer, linebuffer+2, n);
-       }
-
-       linebuffer[n] = '\0';
-
-       return linebuffer;
-}
-
-void DoHelp(HWND hwnd)
-{
-       char word[256];
-       GetWordUnderCursor(hwnd,word,sizeof(word));
-       MessageBox(NULL,word,"Aide pour:",MB_OK);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     RewriteCurrentEditBuffer ID:1
-Purpose:       Rewrites what is at the prompt with the current contents of
-                          the edit buffer
-Input:         None
-Output:        None explicit
-Errors:        None
-------------------------------------------------------------------------*/
-void RewriteCurrentEditBuffer(void)
-{
-       // get the editbox's handle
-       HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-
-       // calculate what to highlight
-       int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0);
-       int lineindex = SendMessage(hEdit,EM_LINEINDEX,LastPromptPosition.line,0) + 2;
-       int lastLine = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0) + SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0) + 100;
-
-       // delete the current text
-       SendMessage(hEdit, EM_SETSEL, (WPARAM)lineindex, (LPARAM)lastLine);
-       SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)"");
-
-       {
-               // loop through each line in the edit buffer and add it to the control
-               LineList* line = CurrentEditBuffer->Lines;
-               for(; line != NULL; line = line->Next)
-               {
-                       // if there is a line before me, add a newline
-                       if(line->Prev != NULL)
-                               SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)"\r\n");
-
-                       // add the line
-                       SendMessage(hEdit, EM_REPLACESEL, (WPARAM)TRUE, (LPARAM)line->Text);
-               }
-       }
-}
-
-/*------------------------------------------------------------------------
-Procedure:     RefreshCurrentEditBuffer ID:1
-Purpose:       Rewrites what is in the CurrentEditBuffer with what is
-                          actually there
-Input:         None
-Output:        None explicit
-Errors:        None
-------------------------------------------------------------------------*/
-void RefreshCurrentEditBuffer(void)
-{
-       // get the editbox's handle
-       HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-
-       // get the last line index
-       int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0) - 1;
-       int i = 0, n = 0;
-
-       // where to hold the line we grab
-       char *linebuffer = (char*)SafeMalloc(2048*sizeof(char));
-       *(unsigned short *)linebuffer = 2047;
-
-       editbuffer_destroy(CurrentEditBuffer);
-       CurrentEditBuffer = editbuffer_new();
-
-       // loop through each line updating or adding it to the current edit buffer
-       for( ; (i + LastPromptPosition.line) <= linesCount; i++)
-       {
-               n = SendMessage(hEdit, EM_GETLINE, (i + LastPromptPosition.line), (LPARAM)linebuffer);
-
-               if ((n >= 2) && (linebuffer[0] == '#') && (linebuffer[1] == ' ')) {
-                       n -= 2;
-                       memmove(linebuffer, linebuffer+2, n);
-               }
-
-               linebuffer[n] = '\0';
-
-               {       // remove line breaks and feeds
-                       char* ln = linebuffer;
-
-                       while((*ln) != 0)
-                       {
-                               switch((*ln))
-                               {
-                                       case '\r':
-                                       case '\n':
-                                               (*ln) = ' ';
-                               }
-
-                               ln++;
-                       }
-               }
-
-               editbuffer_addline(CurrentEditBuffer, linebuffer);
-       }
-}
-
-/*------------------------------------------------------------------------
-Procedure:     NextHistoryEntry ID:1
-Purpose:       Scrolls to the next history entry
-Input:         None
-Output:        None explicit
-Errors:        None
---------------------------------------------------------------------------
-Edit History:
-       17 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added this as a helper function
-       18 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Corrected doubly linked list problems
-------------------------------------------------------------------------*/
-void NextHistoryEntry(void)
-{
-       // out of bounds, put it back into bounds
-       if(historyEntry == NULL && History == NULL)
-       {
-               return;
-       } else if (historyEntry == NULL && History != NULL) {
-               historyEntry = History;
-       } else {
-               if(historyEntry->Next == NULL)
-                       return;
-
-               historyEntry = historyEntry->Next;
-       }
-
-       // if its valid
-       if(historyEntry != NULL)
-       {
-               // copy the history entry to a new buffer
-               EditBuffer* newBuf = editbuffer_copy(historyEntry->Statement);
-
-               // destroy the old buffer
-               editbuffer_destroy(CurrentEditBuffer);
-
-               // setup the current one to the copy
-               CurrentEditBuffer = newBuf;
-
-               // rewrite the old one and go to the prompt
-               RewriteCurrentEditBuffer();
-               GotoPrompt();
-       }
-}
-
-/*------------------------------------------------------------------------
-Procedure:     PrevHistoryEntry ID:1
-Purpose:       Scrolls to the previous history entry
-Input:         None
-Output:        None explicit
-Errors:        None
---------------------------------------------------------------------------
-Edit History:
-       17 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added this as a helper function
-       18 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Corrected doubly linked list problems
-------------------------------------------------------------------------*/
-void PrevHistoryEntry(void)
-{
-       // out of bounds, put it back into bounds
-       if(historyEntry == NULL || History == NULL)
-       {
-               return;
-       } else {
-               if(historyEntry->Prev == NULL)
-                       return;
-
-               historyEntry = historyEntry->Prev;
-       }
-
-       // if its valid
-       if(historyEntry != NULL)
-       {
-               // copy the history entry to a new buffer
-               EditBuffer* newBuf = editbuffer_copy(historyEntry->Statement);
-
-               // destroy the old buffer
-               editbuffer_destroy(CurrentEditBuffer);
-
-               // setup the current one to the copy
-               CurrentEditBuffer = newBuf;
-
-               // rewrite the old one and go to the prompt
-               RewriteCurrentEditBuffer();
-               GotoPrompt();
-       }
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SubClassEdit ID:1
-Purpose:       Handles messages to the editbox
-Input:         
-Output:        
-Errors:
---------------------------------------------------------------------------
-Edit History:
-       14 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Setup handler for up and down arrows
-       15 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Setup framework for history on up arrow
-               - Saves lines you move off of in the edit buffer
-       16 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Proper handling of newline message finished
-               - Fixed ENTER on middle of interior line, moves cursor to the end
-                 and sends the line
-               - Setup the copying and destroying of the old buffer
-               - Included buffer rewrite
-       17 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added C-p/C-n support
-               - Changed UpArrow to C-UpArrow so as to not confuse users
-       18 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added Left and Right arrow line saving
-               - Added backspace and delete line saving and removing
-               - Fixed history scrolling
-       21 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Fixed pasting errors associated with lines being out of bounds
-                 for the buffer
-               - Added error handling, possibly able to handle it diff down the
-                 line
-               - Removed C-Up/C-Dn for history scrolling, buggy at best on my
-                 machine
-------------------------------------------------------------------------*/
-static LRESULT CALLBACK SubClassEdit(HWND hwnd, UINT msg, WPARAM mp1, LPARAM mp2)
-{
-       LRESULT r;
-       int postit=0,nl;
-
-       if (msg == WM_CHAR && mp1 == '\r') {
-               if (!busy) {
-                       r =  GetCurLineIndex(hwnd);
-                       nl = GetNumberOfLines(hwnd);
-
-                       // if we're not the last line
-                       if (r != nl-1)
-                       {
-                               // update or add us, we might not have any lines in the edit buffer
-                               editbuffer_updateoraddline(CurrentEditBuffer, r-LastPromptPosition.line, GetLastLine(hwnd));
-
-                               // scroll to the end, add CrLf then post the newline message
-                               GotoEOF();
-                               AddStringToControl("\r\n");
-                               PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
-                               return 0;
-                       }
-
-                       CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-                       CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-
-                       postit = 1;
-               }
-
-       }
-       else if (msg == WM_CHAR && mp1 == (char)0x08) {
-               int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
-               int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
-               int nextline = 0;
-               int curpoint = 0;
-
-               SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
-               nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint - 1),0);
-
-               if(curpoint <= lineindex)
-               {
-                       return 0;
-               } else if(nextline != curline) {
-                       // delete the line we're on
-
-                       // grab the index
-                       curline -= LastPromptPosition.line;
-
-                       // kill it
-                       editbuffer_removeline(CurrentEditBuffer, curline);
-               }
-       }
-       else if (msg == WM_KEYDOWN && mp1 == VK_F1) {
-               DoHelp(hwnd);
-       }
-       else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && mp1 == VK_UP) {
-               int curline = GetCurLineIndex(hwnd);
-
-               /*if((msg == WM_KEYDOWN) && (GetKeyState(VK_CONTROL) && 0x8000))
-               {       // go forward once in history
-                       NextHistoryEntry();
-                       return 0;
-               } else */
-               if((curline > LastPromptPosition.line) && (curline <= (LastPromptPosition.line + CurrentEditBuffer->LineCount)))
-               {
-                       // update current line
-                       if (msg == WM_KEYDOWN)
-                       {
-                               int lineidx = (curline - LastPromptPosition.line);
-
-                               CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-                               CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-                               
-                               // we may have to add this line, otherwise update it
-                               editbuffer_updateoraddline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
-                       }
-               } else {
-                       return 0;
-               }
-       }
-       else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_LEFT)) {
-               int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
-               int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
-               int nextline = 0;
-               int curpoint = 0;
-
-               SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
-               nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint - 1),0);
-
-               if(curpoint <= lineindex)
-               {       // no left arrow to the left of the prompt
-                       return 0;
-               } else if(nextline != curline) {
-                       // update current line
-                       if (msg == WM_KEYDOWN)
-                       {
-                               int lineidx = (curline - LastPromptPosition.line);
-
-                               CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-                               CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-                               
-                               // we may have to add this line, otherwise update it
-                               editbuffer_updateoraddline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
-
-                               CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_HOME,1);
-                               CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_HOME,1);
-                       }
-               }
-       }
-       else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_DOWN)) {
-               int curline = GetCurLineIndex(hwnd);
-               
-               /*if((msg == WM_KEYDOWN) && (GetKeyState(VK_CONTROL) && 0x8000))
-               {       // go back once in history
-                       PrevHistoryEntry();
-                       return 0;
-               } else*/
-               if((curline >= LastPromptPosition.line) && (curline < (LastPromptPosition.line + CurrentEditBuffer->LineCount)))
-               {
-                       // We don't post the newline, but instead update the current line
-                       if (msg == WM_KEYDOWN)
-                       {
-                               int lineidx = (curline - LastPromptPosition.line);
-
-                               CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-                               CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-                               
-                               editbuffer_updateline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
-                       }
-               } else {
-                       return 0;
-               }
-       }
-       else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_RIGHT)) {
-               int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 1;
-               int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
-               int nextline = 0;
-               int curpoint = 0;
-
-               SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
-               nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint + 2),0);
-
-               if(curpoint <= lineindex)
-               {       // no movement behind the prompt
-                       return 0;
-               } else if((nextline != curline) && (msg = WM_KEYDOWN)) {
-                       int lineidx = (curline - LastPromptPosition.line);
-
-                       CallWindowProc(lpEProc,hwnd,WM_KEYDOWN,VK_END,1);
-                       CallWindowProc(lpEProc,hwnd,WM_KEYUP,VK_END,1);
-                       
-                       editbuffer_updateline(CurrentEditBuffer, lineidx, GetLastLine(hwnd));
-               }
-       }
-       else if ((msg == WM_KEYDOWN) && (mp1 == VK_PRIOR) && (GetKeyState(VK_CONTROL) && 0x8000)) {
-               // C-p
-               NextHistoryEntry();
-               return 0;
-       }
-       else if ((msg == WM_KEYDOWN) && (mp1 == VK_NEXT) && (GetKeyState(VK_CONTROL) && 0x8000)) {
-               // C-n
-               PrevHistoryEntry();
-               return 0;
-       }
-       else if ((msg == WM_KEYDOWN || msg == WM_KEYUP) && (mp1 == VK_DELETE)) {
-               // see if we're the last char on the line, if so delete the next line
-               // don't allow deleting left of the prompt
-               int lineindex = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
-               int curline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)-1,0);
-               int nextline = 0;
-               int curpoint = 0;
-
-               SendMessage(hwnd, EM_GETSEL, (WPARAM)&curpoint, (LPARAM)NULL); 
-               nextline = SendMessage(hwnd,EM_LINEFROMCHAR,(WPARAM)(curpoint + 2),0);
-
-               if(curpoint < lineindex)
-               {       // no chomping behind the prompt
-                       return 0;
-               } else if(nextline != curline) {
-                       // deleting
-                       // grab the next line index
-                       curline -= LastPromptPosition.line;
-
-                       // kill it
-                       editbuffer_removeline(CurrentEditBuffer, curline+1);
-               }
-       }
-       else if (msg == WM_PASTE) {
-               // if they paste text, allow it
-               r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2);
-
-               // update the current edit buffer
-               RefreshCurrentEditBuffer();
-
-               return r;
-       }
-
-       // handle errors
-       switch(msg)
-       {
-               case WM_SYNTAXERROR:
-               case WM_ILLEGALCHAR:
-               case WM_UNBOUNDVAL:
-                       {       // currently I handle them all the same
-                               // get the start of the line
-                               int start = SendMessage(hwnd, EM_LINEINDEX, LastPromptPosition.line, 0) + 2;
-
-                               // get the statement that error'd
-                               NextHistoryEntry();
-
-                               // tell the history that the last line errored
-                               if(History != NULL)
-                                       if(History->Statement != NULL)
-                                               History->Statement->isCorrect = FALSE;
-
-                               // highlight the offending chars
-                               SendMessage(hwnd,EM_SETSEL,(WPARAM)(start + mp1), (LPARAM)(start + mp2));
-                               
-                               return 0;
-                       }
-       }
-
-       r = CallWindowProc(lpEProc, hwnd, msg, mp1, mp2);
-
-       if (postit)
-               PostMessage(GetParent(hwnd),WM_NEWLINE,0,0);
-
-       return r;
-}
-
-static void SubClassEditField(HWND hwnd)
-{
-       if (lpEProc == NULL) {
-               lpEProc = (WNDPROC) GetWindowLongPtr(hwnd, GWLP_WNDPROC);
-       }
-       SetWindowLongPtr(hwnd, GWLP_WNDPROC, (LONG_PTR) SubClassEdit);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SendLastLine ID:1
-Purpose:       Sends the data in the line containing the cursor to
-the interpreter. If this is NOT the last line, copy
-the line to the end of the text.
-Input:         The edit control window handle
-Output:        None explicit
-Errors:        None
-
-REMOVED!
-------------------------------------------------------------------------*/
-void SendLastLine(HWND hEdit)
-{
-/*     int curline = GetCurLineIndex(hEdit);
-       char *p,linebuffer[2048];
-       int n;
-       int linescount = GetNumberOfLines(hEdit);
-
-       *(unsigned short *)linebuffer = sizeof(linebuffer)-1;
-       if (curline != linescount-1)
-               n = SendMessage(hEdit,EM_GETLINE,curline,(LPARAM)linebuffer);
-       else
-               n = SendMessage(hEdit,EM_GETLINE,curline-1,(LPARAM)linebuffer);
-       if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ') {
-               n -= 2;
-               memmove(linebuffer, linebuffer+2, n);
-       }
-       linebuffer[n] = 0;
-
-       // Record user input!
-       AddToHistory(linebuffer);
-       linebuffer[n] = '\n';
-       linebuffer[n+1] = 0;
-       WriteToPipe(linebuffer);
-       if (curline != linescount-1) {
-               // Copy the line sent to the end of the text
-               p = strrchr(linebuffer,'\n');
-               if (p) {
-                       *p = 0;
-               }
-               busy = 1;
-               AddLineToControl(linebuffer);
-               busy = 0;
-       }*/
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SendLastEditBuffer ID:1
-Author:                   Chris Watford watford@uiuc.edu
-Purpose:       Sends an edit buffer to the pipe
-Input:
-Output:
-Errors:
---------------------------------------------------------------------------
-Edit History:
-     7 Aug  2004 - Chris Watford christopher.watford@gmail.com
-               - Fixed error where SendLastEditBuffer sent waaaay too many
-               newlines which completely broke the underlying connection to the
-               ocaml.exe pipe
-       15 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Sends line to the pipe and adds newline to the end
-------------------------------------------------------------------------*/
-void SendLastEditBuffer(HWND hwndChild)
-{
-       char* line = editbuffer_getasbuffer(CurrentEditBuffer);
-       int l = strlen(line) - 1;
-       char* linebuffer = (char*)SafeMalloc(l+2);
-
-       // save current edit buffer to history and create a new blank edit buffer
-       CurrentEditBuffer->isCorrect = TRUE;
-       AddToHistory(CurrentEditBuffer);
-       CurrentEditBuffer = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
-       CurrentEditBuffer->LineCount = 0;
-       CurrentEditBuffer->Lines = NULL;
-
-       // trim and add the newline to the end
-       strncpy(linebuffer, line, l+1);
-       while((linebuffer[l] == '\n' || linebuffer[l] == '\r') && (l >= 0))
-       {
-               linebuffer[l--] = '\0';
-       }
-
-       linebuffer[l+1] = '\n';
-       linebuffer[l+2] = '\0';
-
-       // save line to the pipe
-       WriteToPipe(linebuffer);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SendingFullCommand ID:1
-Author:                   Chris Watford watford@uiuc.edu
-Purpose:       Returns if the command being sent 
-Input:         The edit control window handle
-Output:        None explicit
-Errors:        None
---------------------------------------------------------------------------
-Edit History:
-        7 Aug  2004 - Chris Watford christopher.watford@gmail.com
-               - Fixed bug #2932 where many carraige returns were sent and it came
-               back with a null pointer error due to a fault of not checking if
-               the line returned was NULL
-       13 Oct  2003 - Chris Watford watford@uiuc.edu
-               - Solved the error when you have a malformed comment in the buffer
-------------------------------------------------------------------------*/
-BOOL SendingFullCommand(void)
-{
-       // if there is a ;; on the line, return true
-       char *line = editbuffer_getasline(CurrentEditBuffer);
-       char *firstComment, *firstSemiColonSemiColon, *firstQuote;
-
-       if(line == NULL)
-       {
-               return FALSE;
-       }
-
-       firstComment = strstr(line, "(*");
-       firstSemiColonSemiColon = strstr(line, ";;");
-       firstQuote = strstr(line, "\"");
-
-       // easy case :D
-       if(firstSemiColonSemiColon == NULL)
-       {
-               free(line);
-               return FALSE;
-       }
-
-       // if there are no comments
-       if(firstComment == NULL)
-       {
-               // if there are no quotations used
-               if(firstQuote == NULL)
-               {
-                       BOOL r = (firstSemiColonSemiColon != NULL);
-                       free(line);
-                       return r;
-               } else {
-                       // we need to first check if the ;; is before the \", since the \"
-                       // won't matter if its before the semicolonsemicolon
-                       if(firstQuote < firstSemiColonSemiColon)
-                       {
-                               // the quote is before the ;;, we need to make sure its terminated
-                               // also we have to check for escaped quotes, le sigh!
-                               char *c = firstQuote+1;
-                               BOOL in_quote = TRUE;
-                               
-                               // in-quote determiner loop
-                               while(c[0] != '\0')
-                               {
-                                       // are we a backslash?
-                                       if(c[0] == '\\')
-                                       {
-                                               // ignore the next character
-                                               c++;
-                                       }
-                                       else
-                                       {
-                                                       // are we a quote?
-                                               if(c[0] == '"')
-                                               {
-                                                       in_quote = !in_quote;
-                                               }
-                                       }
-
-                                       c++;
-                               }
-
-                               free(line);
-                               return !in_quote;
-                       } else {
-                               BOOL r = (firstSemiColonSemiColon != NULL);
-                               free(line);
-                               return r;
-                       }
-               }
-       } else {
-               // we have to search through finding all comments
-
-               // a neat little trick we can do is compare the point at which
-               // the ;; is and where the first (* can be found, if the ;; is
-               // before the (* ocaml.exe ignores the comment
-               if((unsigned int)firstSemiColonSemiColon < (unsigned int)firstComment)
-               {
-                       free(line);
-                       return TRUE;
-               } else {
-                       // time to search and find if the endline is inside a comment or not
-                       // start at the first comment, and move forward keeping track of the
-                       // nesting level, if the nest level is 0, i.e. outside a comment
-                       // and we find the ;; return TRUE immediately, otherwise keep searching
-                       // if we end with a nest level >0 return FALSE
-
-                       char *c = firstComment+2; // firstComment[0] is the '(', firstComment[1] is the '*'
-                       int nestLevel = 1; // we have a (*
-
-                       // in-comment determiner loop
-                       while(c[0] != '\0')
-                       {
-                               // are we an endline
-                               if((c[0] == ';') && (c[1] == ';'))
-                               {
-                                       // if we are NOT in a comment, its a full line
-                                       if(nestLevel <= 0)
-                                       {
-                                               free(line);
-                                               return TRUE;
-                                       }
-                               }
-
-                               // are we in a comment?
-                               if((c[0] == '(') && (c[1] == '*'))
-                               {
-                                       nestLevel++;
-
-                                       // watch out we may go past the end
-                                       if(c[2] == '\0')
-                                       {
-                                               free(line);
-                                               return FALSE;
-                                       }
-
-                                       // c needs to advance past the *, cause (*) is NOT the start/finish of a comment
-                                       c++;
-                               }
-
-                               // adjust the nesting down a level
-                               if((c[0] == '*') && (c[1] == ')'))
-                                       nestLevel--;
-
-                               // next char
-                               c++;
-                       }
-
-                       // not a full line
-                       free(line);
-                       return FALSE;
-               }
-       }
-
-       // weird case ;)
-       free(line);
-       return FALSE;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     AppendToEditBuffer ID:1
-Author:                   Chris Watford watford@uiuc.edu
-Purpose:       Add a line to the edit buffer
-Input:            Handle of the edit control
-Output:
-Errors:
-------------------------------------------------------------------------*/
-void AppendToEditBuffer(HWND hEdit)
-{
-       char *p = NULL, linebuffer[2048];
-       int n = 0;
-       int curline = GetCurLineIndex(hEdit);
-       int linescount = GetNumberOfLines(hEdit);
-
-       // they are passing the size of the buffer as
-       // the first 'short' in the array...
-       *(unsigned short *)linebuffer = sizeof(linebuffer)-1;
-
-       if (curline > (linescount-1))
-       {
-               n = SendMessage(hEdit, EM_GETLINE, curline, (LPARAM)linebuffer);
-       } else {
-               n = SendMessage(hEdit, EM_GETLINE, --curline, (LPARAM)linebuffer);
-       }
-
-       // correct for the prompt line
-       if (n >= 2 && linebuffer[0] == '#' && linebuffer[1] == ' ')
-       {
-               n -= 2;
-               memmove(linebuffer, linebuffer+2, n);
-       }
-
-       linebuffer[n] = '\0';
-
-       // linebuffer now has the line to add to our edit buffer
-       editbuffer_updateoraddline(CurrentEditBuffer, (curline - LastPromptPosition.line), linebuffer);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     SetLastPrompt ID:1
-Purpose:       Record the position of the last prompt ("# ") sent by
-the interpreter. This isn't really used yet.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-void SetLastPrompt(HWND hEdit)
-{
-       DWORD startpos,endpos;
-       SendMessage(hEdit,EM_GETSEL,(WPARAM)&startpos,(LPARAM)&endpos);
-       LastPromptPosition.line = SendMessage(hEdit,EM_LINEFROMCHAR,(WPARAM)-1,0);
-       LastPromptPosition.col = startpos;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     MdiChildWndProc ID:1
-Purpose:       The edit control is enclosed in a normal MDI window.
-This is the window procedure for that window. When it
-receives the WM_CREATE message, it will create the
-edit control.
-Input:
-Output:
-Errors:
---------------------------------------------------------------------------
-Edit History:
-       14 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added edit buffer and statement buffer support to the WM_NEWLINE
-                 message.
-       15 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Got it adding to the edit buffer
-       16 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Proper handling of newline message finished
-       21 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Added error detection on return from ocaml interp
-       23 Sept 2003 - Chris Watford watford@uiuc.edu
-               - Fixed prompt detection error as pointed out by Patrick Meredith
-------------------------------------------------------------------------*/
-static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM lparam)
-{
-       HWND hwndChild;
-       RECT rc;
-       HDC hDC;
-
-       switch(msg) {
-               case WM_CREATE:
-                       GetClientRect(hwnd,&rc);
-                       hwndChild= CreateWindow("EDIT",
-                               NULL,
-                               WS_CHILD | WS_VISIBLE |
-                               ES_MULTILINE |
-                               WS_VSCROLL | WS_HSCROLL |
-                               ES_AUTOHSCROLL | ES_AUTOVSCROLL,
-                               0,
-                               0,
-                               (rc.right-rc.left),
-                               (rc.bottom-rc.top),
-                               hwnd,
-                               (HMENU) EditControls++,
-                               hInst,
-                               NULL);
-                       SetWindowLongPtr(hwnd, DWLP_USER, (LONG_PTR) hwndChild);
-                       SendMessage(hwndChild, WM_SETFONT, (WPARAM) ProgramParams.hFont, 0L);
-                       SendMessage(hwndChild,EM_LIMITTEXT,0xffffffff,0);
-                       SubClassEditField(hwndChild);
-                       break;
-                       // Resize the edit control
-               case WM_SIZE:
-                       hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER);
-                       MoveWindow(hwndChild, 0, 0, LOWORD(lparam), HIWORD(lparam), TRUE);
-                       break;
-                       // Always set the focus to the edit control.
-               case WM_SETFOCUS:
-                       hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER);
-                       SetFocus(hwndChild);
-                       break;
-                       // Repainting of the edit control about to happen.
-                       // Set the text color and the background color
-               case WM_CTLCOLOREDIT:
-                       hDC = (HDC)wparam;
-                       SetTextColor(hDC,ProgramParams.TextColor);
-                       SetBkColor(hDC,BackColor);
-                       return (LRESULT)BackgroundBrush;
-                       // Take care of erasing the background color to avoid flicker
-               case WM_ERASEBKGND:
-                       GetWindowRect(hwnd,&rc);
-                       hDC = (HDC)wparam;
-                       FillRect(hDC,&rc,BackgroundBrush);
-                       return 1;
-                       // A carriage return has been pressed. Send the data to the interpreted.
-                       // This message is posted by the subclassed edit field.
-               case WM_COMMAND:
-                       if (LOWORD(wparam) >= IDEDITCONTROL && LOWORD(wparam) < IDEDITCONTROL+5) {
-                               switch (HIWORD(wparam)) {
-                                       case EN_ERRSPACE:
-                                       case EN_MAXTEXT:
-                                               ResetText();
-                                               break;
-                               }
-                       }
-                       break;
-               case WM_NEWLINE:
-                       if (busy)
-                               break;
-
-                       hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER);
-
-                       // add what they wrote to the edit buffer
-                       AppendToEditBuffer(hwndChild);
-
-               /** Modified by Chris Watford 14 Sept 2003, 15 Sept 2003, 16 Sept 2003 **/
-                       // test if this line has an end or if it needs to be in the Edit Buffer
-                       if(SendingFullCommand())
-                       {
-                               // send the edit buffer to the interpreter
-                               //SendLastLine(hwndChild);
-                               SendLastEditBuffer(hwndChild);
-                               historyEntry = NULL;
-                       } else {
-                               AddStringToControl("  ");
-                       }
-               /** End Modifications **/
-
-                       break;
-                       // The timer will call us 4 times a second. Look if the interpreter
-                       // has written something in its end of the pipe.
-               case WM_TIMERTICK:
-               /** Modified by Chris Watford 21 Sept 2003 **/
-                       hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER);
-
-                       if (ReadToLineBuffer())
-                       {
-                               int errMsg = 0;
-                               char *p, *l = lineBuffer;
-
-                               // Ok we read something. Display the trimmed version
-                               while(((*l) == ' ') || ((*l) == '\t') || ((*l) == '\n') || ((*l) == '\r') || ((*l) == '*'))
-                                       l++;
-
-                               SendMessage(hwndChild,EM_REPLACESEL,0,(LPARAM)l);
-
-                               // fix bug where it won't find prompt
-                               p = strrchr(l, '\r');
-                               if((l[0] == '#') || (p != NULL))
-                               {
-                                       if(p != NULL)
-                                       {
-                                               if(!strcmp(p, "\r\n# "))
-                                               {
-                                                       SetLastPrompt(hwndChild);
-                                               }
-                                       // solve the bug Patrick found
-                                       } else if((l[0] == '#') && (l[1] == ' ')) {
-                                               SetLastPrompt(hwndChild);
-                                       }
-                               }
-
-                               // detect syntax errors
-                               if(strstr(lineBuffer, "Syntax error"))
-                               {
-                                       errMsg = WM_SYNTAXERROR;
-                               } else if(strstr(lineBuffer, "Illegal character")) {
-                                       errMsg = WM_ILLEGALCHAR;
-                               } else if(strstr(lineBuffer, "Unbound value")) {
-                                       errMsg = WM_UNBOUNDVAL;
-                               }
-
-                               // error! error! alert alert!
-                               if(errMsg > 0)
-                               {
-                                       int len = strlen(lineBuffer);
-                                       char* err = (char*)SafeMalloc(len+1);
-                                       char *m = err, *n1 = NULL, *n2 = NULL, *nt = NULL;
-
-                                       // make a copy of the message
-                                       strncpy(err, lineBuffer, len);
-                                       err[len] = '\0';
-
-                                       // find it
-                                       m = strstr(err, "Characters ");
-                                       if(m == NULL)
-                                               break;
-
-                                       // got the start char
-                                       n1 = m + strlen("Characters ");
-                                       
-                                       // start looking for the end char
-                                       nt = strstr(n1, "-");
-                                       if(nt == NULL)
-                                               break;
-                                       
-                                       // makes n1 a valid string
-                                       nt[0] = '\0';
-
-                                       // end char is right after this
-                                       n2 = nt + 1;
-
-                                       // find the end of n2
-                                       nt = strstr(n2, ":");
-                                       if(nt == NULL)
-                                               break;
-
-                                       // makes n2 a valid string
-                                       nt[0] = '\0';
-
-                                       SendMessage(hwndChild, errMsg, (WPARAM)atoi(n1), (LPARAM)atoi(n2));
-                               }
-                       }
-               /** End Modifications **/
-
-                       break;
-
-       }
-       return DefMDIChildProc(hwnd, msg, wparam, lparam);
-}
-
-
-/*------------------------------------------------------------------------
-Procedure:     MainWndProc ID:1
-Purpose:       Window procedure for the frame window, that contains
-the menu. The messages handled are:
-WM_CREATE: Creates the mdi child window
-WM_SIZE: resizes the status bar and the mdi child
-window
-WM_COMMAND: Sends the command to the dispatcher
-WM_CLOSE: If the user confirms, it exists the program
-WM_QUITOCAML: Stops the program unconditionally.
-Input:         Standard windows callback
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static LRESULT CALLBACK MainWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM lParam)
-{
-       switch (msg) {
-               // Create the MDI client invisible window
-               case WM_CREATE:
-                       hwndMDIClient = CreateMdiClient(hwnd);
-                       TimerId = SetTimer((HWND) 0, 0, 100, (TIMERPROC) TimerProc);
-                       break;
-                       // Move the child windows
-               case WM_SIZE:
-                       SendMessage(hWndStatusbar,msg,wParam,lParam);
-                       InitializeStatusBar(hWndStatusbar,1);
-                       // Position the MDI client window between the tool and status bars
-                       if (wParam != SIZE_MINIMIZED) {
-                               RECT rc, rcClient;
-
-                               GetClientRect(hwnd, &rcClient);
-                               GetWindowRect(hWndStatusbar, &rc);
-                               ScreenToClient(hwnd, (LPPOINT)&rc.left);
-                               rcClient.bottom = rc.top;
-                               MoveWindow(hwndMDIClient,rcClient.left,rcClient.top,rcClient.right-rcClient.left, rcClient.bottom-rcClient.top, TRUE);
-                       }
-
-                       return 0;
-                       // Dispatch the menu commands
-               case WM_COMMAND:
-                       HandleCommand(hwnd, wParam,lParam);
-                       return 0;
-                       // If user confirms close
-               case WM_CLOSE:
-                       if (!AskYesOrNo("Quit OCamlWinPlus?"))
-                               return 0;
-                       break;
-                       // End application
-               case WM_DESTROY:
-                       PostQuitMessage(0);
-                       break;
-                       // The interpreter has exited. Force close of the application
-               case WM_QUITOCAML:
-                       DestroyWindow(hwnd);
-                       return 0;
-               case WM_USER+1000:
-                       // TestGraphics();
-                       break;
-               default:
-                       return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
-       }
-       return DefFrameProc(hwnd,hwndMDIClient,msg,wParam,lParam);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     CreationCourier ID:1
-Purpose:       Creates the courier font
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static HFONT CreationCourier(int flag)
-{
-       LOGFONT CurrentFont;
-       memset(&CurrentFont, 0, sizeof(LOGFONT));
-       CurrentFont.lfCharSet = ANSI_CHARSET;
-       CurrentFont.lfWeight = FW_NORMAL;
-       if (flag)
-               CurrentFont.lfHeight = 18;
-       else
-               CurrentFont.lfHeight = 15;
-       CurrentFont.lfPitchAndFamily = (BYTE) (FIXED_PITCH | FF_MODERN);
-       strcpy(CurrentFont.lfFaceName, "Courier");  /* Courier */
-       return (CreateFontIndirect(&CurrentFont));
-}
-
-/*------------------------------------------------------------------------
-Procedure:     ReadToLineBuffer ID:1
-Purpose:       Reads into the line buffer the characters written by
-the interpreter
-Input:         None
-Output:        The number of characters read
-Errors:        None
-------------------------------------------------------------------------*/
-int ReadToLineBuffer(void)
-{
-       memset(lineBuffer,0,sizeof(lineBuffer));
-       return ReadFromPipe(lineBuffer,sizeof(lineBuffer));
-}
-
-/*------------------------------------------------------------------------
-Procedure:     AddLineBuffer ID:1
-Purpose:       Sends the contents of the line buffer to the edit
-control
-Input:         None
-Output:
-Errors:
-------------------------------------------------------------------------*/
-int AddLineBuffer(void)
-{
-       HWND hEditCtrl;
-
-       hEditCtrl = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER);
-       return SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)lineBuffer);
-
-}
-
-/*------------------------------------------------------------------------
-Procedure:     Setup ID:1
-Purpose:       Handles GUI initialization (Fonts, brushes, colors,
-etc)
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-static int Setup(HANDLE *phAccelTable)
-{
-       if (!InitApplication())
-               return 0;
-       ProgramParams.hFont = CreationCourier(1);
-       ProgramParams.TextColor = RGB(0,0,0);
-       GetObject(ProgramParams.hFont,sizeof(LOGFONT),&CurrentFont);
-       BackgroundBrush = CreateSolidBrush(BackColor);
-       *phAccelTable = LoadAccelerators(hInst,MAKEINTRESOURCE(IDACCEL));
-       return 1;
-}
-
-
-/*------------------------------------------------------------------------
-Procedure:     WinMain ID:1
-Purpose:       Entry point for windows programs.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine, INT nCmdShow)
-{
-       MSG msg;
-       HANDLE hAccelTable;
-       char consoleTitle[512];
-       HWND hwndConsole;
-
-       CurrentEditBuffer = (EditBuffer*)SafeMalloc(sizeof(EditBuffer));
-       CurrentEditBuffer->LineCount = 0;
-       CurrentEditBuffer->Lines = NULL;
-
-       //setup the history index pointer
-       historyEntry = NULL;
-
-       // Setup the hInst global
-       hInst = hInstance;
-       // Do the setup
-       if (!Setup(&hAccelTable))
-               return 0;
-       // Need to set up a console so that we can send ctrl-break signal
-       // to inferior Caml
-       AllocConsole();
-       GetConsoleTitle(consoleTitle,sizeof(consoleTitle));
-       hwndConsole = FindWindow(NULL,consoleTitle);
-       ShowWindow(hwndConsole,SW_HIDE);
-       // Create main window and exit if this fails
-       if ((hwndMain = CreateinriaWndClassWnd()) == (HWND)0)
-               return 0;
-       // Create the status bar
-       CreateSBar(hwndMain,"Ready",2);
-       // Show the window
-       ShowWindow(hwndMain,SW_SHOW);
-       // Create the session window
-       hwndSession = MDICmdFileNew("Session transcript",0);
-       // Get the path to ocaml.exe
-       GetOcamlPath();
-       // Start the interpreter
-       StartOcaml();
-       // Show the session window
-       ShowWindow(hwndSession, SW_SHOW);
-       // Maximize it
-       SendMessage(hwndMDIClient, WM_MDIMAXIMIZE, (WPARAM) hwndSession, 0);
-
-       PostMessage(hwndMain,WM_USER+1000,0,0);
-       while (GetMessage(&msg,NULL,0,0)) {
-               if (!TranslateMDISysAccel(hwndMDIClient, &msg))
-                       if (!TranslateAccelerator(msg.hwnd, hAccelTable, &msg)) {
-                               TranslateMessage(&msg);  // Translates virtual key codes
-                               DispatchMessage(&msg);   // Dispatches message to window
-                       }
-       }
-       WriteToPipe("#quit;;\r\n\032");
-       KillTimer((HWND) 0, TimerId);
-       return msg.wParam;
-}

diff --git a/win32caml/ocaml.ico b/win32caml/ocaml.ico
deleted file mode 100644 (file)
index 13560db..0000000
Binary files a/win32caml/ocaml.ico and /dev/null differ

diff --git a/win32caml/ocaml.rc b/win32caml/ocaml.rc
deleted file mode 100644 (file)
index 52ae949..0000000
--- a/win32caml/ocaml.rc
+++ /dev/null
@@ -1,255 +0,0 @@
-// Microsoft Visual C++ generated resource script.
-//
-#include "resource.h"
-
-#define APSTUDIO_READONLY_SYMBOLS
-/////////////////////////////////////////////////////////////////////////////
-//
-// Generated from the TEXTINCLUDE 2 resource.
-//
-#define APSTUDIO_HIDDEN_SYMBOLS
-#include "windows.h"
-#undef APSTUDIO_HIDDEN_SYMBOLS
-#include "inriares.h"
-
-/////////////////////////////////////////////////////////////////////////////
-#undef APSTUDIO_READONLY_SYMBOLS
-
-/////////////////////////////////////////////////////////////////////////////
-// English (U.S.) resources
-
-#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU)
-#ifdef _WIN32
-LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US
-#pragma code_page(1252)
-#endif //_WIN32
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// Icon
-//
-
-// Icon with lowest ID value placed first to ensure application icon
-// remains consistent on all systems.
-1000                    ICON                    "ocaml.ico"
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// Menu
-//
-
-IDMAINMENU MENU 
-BEGIN
-    POPUP "&File"
-    BEGIN
-        MENUITEM "&Open...",                    IDM_OPEN
-        MENUITEM "&Save ML...",                 IDM_SAVE
-        MENUITEM "Save &Transcript...",         IDM_SAVEAS
-        MENUITEM SEPARATOR
-        MENUITEM "&Print",                      IDM_PRINT, GRAYED
-        MENUITEM "P&rint Setup...",             IDM_PRINTSU, GRAYED
-        MENUITEM SEPARATOR
-        MENUITEM "E&xit",                       IDM_EXIT
-    END
-    POPUP "&Edit"
-    BEGIN
-        MENUITEM "&Undo\tAlt+BkSp",             IDM_EDITUNDO
-        MENUITEM SEPARATOR
-        MENUITEM "Cu&t\t Shift+Del",            IDM_EDITCUT
-        MENUITEM "&Copy\tCtrl+Ins",             IDM_EDITCOPY
-        MENUITEM "&Paste\tShift+Ins",           IDM_EDITPASTE
-    END
-    POPUP "Workspace"
-    BEGIN
-        MENUITEM "&Font...",                    IDM_FONT
-        MENUITEM "Text &Color...",              IDM_COLORTEXT
-        MENUITEM "&Background Color...",        IDM_BACKCOLOR
-        MENUITEM SEPARATOR
-        MENUITEM "&History...",                 IDM_HISTORY
-        MENUITEM "&Garbage Collect",            IDM_GC
-        MENUITEM "&Interrupt",                  IDCTRLC
-    END
-    POPUP "&Window", GRAYED
-    BEGIN
-        MENUITEM "&Tile",                       IDM_WINDOWTILE, INACTIVE
-        MENUITEM "&Cascade",                    IDM_WINDOWCASCADE, INACTIVE
-        MENUITEM "Arrange &Icons",              IDM_WINDOWICONS, INACTIVE
-        MENUITEM "Close &All",                  IDM_WINDOWCLOSEALL, INACTIVE
-    END
-    POPUP "&Help"
-    BEGIN
-        MENUITEM "&About...",                   IDM_ABOUT
-    END
-END
-
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// Accelerator
-//
-
-BARMDI ACCELERATORS 
-BEGIN
-    "Q",            IDM_EXIT,               VIRTKEY, CONTROL
-END
-
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// Dialog
-//
-
-IDD_ABOUT DIALOGEX 7, 29, 236, 81
-STYLE DS_SETFONT | DS_CENTER | WS_POPUP | WS_VISIBLE | WS_CAPTION | 
-    WS_SYSMENU
-EXSTYLE WS_EX_TOOLWINDOW | WS_EX_CLIENTEDGE
-CAPTION "About OCamlWinPlus"
-FONT 8, "MS Sans Serif", 0, 0, 0x1
-BEGIN
-    LTEXT           "Objective Caml for Windows",101,75,7,90,12
-    LTEXT           "New Windows Interface 1.9RC4",102,68,15,104,12
-    CTEXT           "Copyright 1996-2001\nUpdated 2003",103,88,25,66,23
-    CTEXT           "Institut National de Recherche en Informatique et Automatique",
-                    104,16,46,211,10
-    CTEXT           "Réalisé par Jacob Navia 2001.  Updated by Chris Watford 2003.\nwatford@uiuc.edu",
-                    105,18,54,207,19
-END
-
-IDD_HISTORY DIALOGEX 6, 18, 261, 184
-STYLE DS_SETFONT | DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | 
-    WS_SYSMENU | WS_THICKFRAME
-EXSTYLE WS_EX_TOOLWINDOW
-CAPTION "Session History"
-FONT 8, "MS Sans Serif", 0, 0, 0x1
-BEGIN
-    LISTBOX         IDLIST,7,7,247,173,LBS_USETABSTOPS | WS_VSCROLL | 
-                    WS_HSCROLL | WS_TABSTOP
-END
-
-
-#ifdef APSTUDIO_INVOKED
-/////////////////////////////////////////////////////////////////////////////
-//
-// TEXTINCLUDE
-//
-
-1 TEXTINCLUDE 
-BEGIN
-    "resource.h\0"
-END
-
-2 TEXTINCLUDE 
-BEGIN
-    "#define APSTUDIO_HIDDEN_SYMBOLS\r\n"
-    "#include ""windows.h""\r\n"
-    "#undef APSTUDIO_HIDDEN_SYMBOLS\r\n"
-    "#include ""inriares.h""\r\n"
-    "\0"
-END
-
-3 TEXTINCLUDE 
-BEGIN
-    "\r\n"
-    "\0"
-END
-
-#endif    // APSTUDIO_INVOKED
-
-
-/////////////////////////////////////////////////////////////////////////////
-//
-// String Table
-//
-
-STRINGTABLE 
-BEGIN
-    3010                    "Switches to "
-END
-
-STRINGTABLE 
-BEGIN
-    2000                    "Create, open, save, or print documents"
-    2010                    "Get help"
-END
-
-STRINGTABLE 
-BEGIN
-    500                     "Displays information about this application"
-END
-
-STRINGTABLE 
-BEGIN
-    440                     "Closes all open windows"
-END
-
-STRINGTABLE 
-BEGIN
-    420                     "Arranges windows as overlapping tiles"
-    430                     "Arranges minimized window icons"
-END
-
-STRINGTABLE 
-BEGIN
-    410                     "Arranges windows as non-overlapping tiles"
-END
-
-STRINGTABLE 
-BEGIN
-    340                     "Inserts the clipboard contents at the insertion point"
-    350                     "Removes the selection without putting it on the clipboard"
-END
-
-STRINGTABLE 
-BEGIN
-    320                     "Cuts the selection and puts it on the clipboard"
-    330                     "Copies the selection and puts it on the clipboard"
-END
-
-STRINGTABLE 
-BEGIN
-    310                     "Reverses the last action"
-END
-
-STRINGTABLE 
-BEGIN
-    260                     "Changes the printer selection or configuration"
-    270                     "Quits this application"
-END
-
-STRINGTABLE 
-BEGIN
-    240                     "Closes the active document"
-    250                     "Prints the active document"
-END
-
-STRINGTABLE 
-BEGIN
-    230                     "Saves the active document under a different name"
-END
-
-STRINGTABLE 
-BEGIN
-    210                     "Opens an existing document"
-    220                     "Saves the active document"
-END
-
-STRINGTABLE 
-BEGIN
-    200                     "Creates a new session"
-END
-
-#endif    // English (U.S.) resources
-/////////////////////////////////////////////////////////////////////////////
-
-
-
-#ifndef APSTUDIO_INVOKED
-/////////////////////////////////////////////////////////////////////////////
-//
-// Generated from the TEXTINCLUDE 3 resource.
-//
-
-
-/////////////////////////////////////////////////////////////////////////////
-#endif    // not APSTUDIO_INVOKED
-

diff --git a/win32caml/resource.h b/win32caml/resource.h
deleted file mode 100644 (file)
index 6762597..0000000
--- a/win32caml/resource.h
+++ /dev/null
@@ -1,16 +0,0 @@
-//{{NO_DEPENDENCIES}}
-// Microsoft Visual C++ generated include file.
-// Used by ocaml.rc
-//
-
-// Next default values for new objects
-// 
-#ifdef APSTUDIO_INVOKED
-#ifndef APSTUDIO_READONLY_SYMBOLS
-#define _APS_NO_MFC                     1
-#define _APS_NEXT_RESOURCE_VALUE        101
-#define _APS_NEXT_COMMAND_VALUE         40001
-#define _APS_NEXT_CONTROL_VALUE         1000
-#define _APS_NEXT_SYMED_VALUE           101
-#endif
-#endif

diff --git a/win32caml/startocaml.c b/win32caml/startocaml.c
deleted file mode 100644 (file)
index f1a3562..0000000
--- a/win32caml/startocaml.c
+++ /dev/null
@@ -1,362 +0,0 @@
-/***********************************************************************/
-/*                                                                     */
-/*                           Objective Caml                            */
-/*                                                                     */
-/*  Developed by Jacob Navia.                                          */
-/*  Copyright 2001 Institut National de Recherche en Informatique et   */
-/*  en Automatique.  All rights reserved.  This file is distributed    */
-/*  under the terms of the GNU Library General Public License, with    */
-/*  the special exception on linking described in file ../LICENSE.     */
-/*                                                                     */
-/***********************************************************************/
-
-/***********************************************************************/
-/* Changes made by Chris Watford to enhance the source editor          */
-/* Began 14 Sept 2003 - watford@uiuc.edu                               */
-/***********************************************************************/
-
-/* $Id$ */
-
-#include <windows.h>
-#include <stdio.h>
-#include <io.h>
-#include <direct.h>
-#include "inria.h"
-
-PROCESS_INFORMATION pi;
-#define BUFSIZE 4096
-STARTUPINFO startInfo;
-
-/*------------------------------------------------------------------------
-Procedure:     ShowDbgMsg ID:1
-Purpose:       Puts up a dialog box with a message, forcing it to
-the foreground.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-void ShowDbgMsg(char *str)
-{
-       HWND hWnd;
-       char p[20], message[255];
-       hWnd = hwndMain;
-       if (IsIconic(hWnd)){
-               ShowWindow(hWnd,SW_RESTORE);
-       }
-       strncpy(message, str, 254);
-       message[254] = 0;
-       strcpy(p, "Error");
-       MessageBox(hWnd, message, p, MB_OK | MB_ICONHAND|MB_TASKMODAL|MB_SETFOREGROUND);
-}
-
-int AskYesOrNo(char *msg)
-{
-       HWND hwnd;
-       int r;
-
-       hwnd = hwndMain;
-       r = MessageBox(hwnd, msg, "Ocaml", MB_YESNO | MB_SETFOREGROUND);
-       if (r == IDYES)
-               return (TRUE);
-       return (FALSE);
-}
-
-
-static DWORD OcamlStatus;
-
-static int RegistryError(void)
-{
-       char buf[512];
-
-       wsprintf(buf,"Error %d writing to the registry",GetLastError());
-       ShowDbgMsg(buf);
-       return 0;
-}
-
-static int ReadRegistry(HKEY hroot,
-                                               char * p1, char * p2, char * p3,
-                                               char dest[1024])
-{
-       HKEY h1, h2;
-       DWORD dwType;
-       unsigned long size;
-       LONG ret;
-
-       if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
-               return 0;
-       if (RegOpenKeyExA(h1, p2, 0, KEY_QUERY_VALUE, &h2) != ERROR_SUCCESS) {
-               RegCloseKey(h1);
-               return 0;
-       }
-       dwType = REG_SZ;
-       size = 1024;
-       ret = RegQueryValueExA(h2, p3, 0, &dwType, dest, &size);
-       RegCloseKey(h2);
-       RegCloseKey(h1);
-       return ret == ERROR_SUCCESS;
-}
-
-static int WriteRegistry(HKEY hroot,
-                                                char * p1, char * p2, char * p3,
-                                                char data[1024])
-{
-       HKEY h1, h2;
-       DWORD disp;
-       LONG ret;
-
-       if (RegOpenKeyExA(hroot, p1, 0, KEY_QUERY_VALUE, &h1) != ERROR_SUCCESS)
-               return 0;
-       if (RegCreateKeyExA(h1, p2, 0, NULL, 0, KEY_ALL_ACCESS, NULL, &h2, &disp)
-               != ERROR_SUCCESS) {
-                       RegCloseKey(h1);
-                       return 0;
-               }
-               ret = RegSetValueEx(h2, p3, 0, REG_SZ, data, strlen(data) + 1);
-               RegCloseKey(h2);
-               RegCloseKey(h1);
-               return ret == ERROR_SUCCESS;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     GetOcamlPath ID:1
-Purpose:       Read the registry key 
-HKEY_LOCAL_MACHINE\Software\Objective Caml
-or
-HKEY_CURRENT_USER\Software\Objective Caml,
-and creates it if it doesn't exists.
-If any error occurs, i.e. the
-given path doesn't exist, or the key didn't exist, it
-will put up a browse dialog box to allow the user to
-enter the path. The path will be verified that it
-points to a file that exists. If that file is in a
-directory called 'bin', it will look for another
-directory in the same level called lib' and set the
-Lib path to that.
-Input:         None explicit
-Output:        1 means sucess, zero failure
-Errors:        Almost all system calls will be verified
-------------------------------------------------------------------------*/
-int GetOcamlPath(void)
-{
-  char path[1024], *p;
-
-  while (( !ReadRegistry(HKEY_CURRENT_USER,
-                        "Software", "Objective Caml",
-                        "InterpreterPath", path)
-          &&
-          !ReadRegistry(HKEY_LOCAL_MACHINE,
-                        "Software", "Objective Caml",
-                        "InterpreterPath", path))
-        || _access(path, 0) != 0) {
-    /* Registry key doesn't exist or contains invalid path */
-    /* Ask user */
-    if (!BrowseForFile("Ocaml interpreter|ocaml.exe", path)) {
-      ShowDbgMsg("Impossible to find ocaml.exe. I quit");
-      exit(0);
-    }
-    WriteRegistry(HKEY_CURRENT_USER,
-                 "Software", "Objective Caml",
-                 "InterpreterPath", path);
-    /* Iterate to validate again */
-  }
-  strcpy(OcamlPath, path);
-  p = strrchr(OcamlPath,'\\');
-  if (p) {
-    *p = 0;
-    strcpy(LibDir,OcamlPath);
-    *p = '\\';
-    p = strrchr(LibDir,'\\');
-    if (p && !stricmp(p,"\\bin")) {
-      *p = 0;
-      strcat(LibDir,"\\lib");
-    }
-  }
-  return 1;
-}
-
-static HANDLE hChildStdinRd, hChildStdinWr,hChildStdoutRd, hChildStdoutWr;
-/*------------------------------------------------------------------------
-Procedure:     IsWindowsNT ID:1
-Purpose:       Returns 1 if we are running under windows NT, zero
-otherwise.
-Input:         None
-Output:        1 or zero
-Errors:
-------------------------------------------------------------------------*/
-int IsWindowsNT(void)
-{
-       OSVERSIONINFO osv;
-
-       osv.dwOSVersionInfoSize = sizeof(osv);
-       GetVersionEx(&osv);
-       return(osv.dwPlatformId == VER_PLATFORM_WIN32_NT);
-}
-
-/*------------------------------------------------------------------------
-Procedure:     DoStartOcaml ID:1
-Purpose:       Starts the ocaml interpreter ocaml.exe. The standard
-input of the interpreter will be connected to a pipe,
-and the standard output and standard error to another
-pipe. The interpreter starts as a hidden process,
-showing only in the task list. Since this is in an
-own thread, its workings are independent of the rest
-of the program. After starting the interpreter, the
-thread waits in case the interpreter exits, for
-instance if the user or some program types #quit;;.
-In this case, the waiting thread awakens and exits
-the user interface.
-Input:         Not used. It uses the OcamlPath global variable, that
-is supposed to be correct, no test for its validity
-are done here.
-Output:        None visible
-Errors:        If any system call for whatever reason fails, the
-thread will exit. No error message is shown.
-------------------------------------------------------------------------*/
-DWORD WINAPI DoStartOcaml(LPVOID param)
-{
-        HWND hwndParent = (HWND) param;
-       char *cmdline;
-       int processStarted;
-       LPSECURITY_ATTRIBUTES lpsa=NULL;
-       SECURITY_ATTRIBUTES sa;
-       SECURITY_DESCRIPTOR sd;
-
-       sa.nLength = sizeof(SECURITY_ATTRIBUTES);
-       // Under windows NT/2000/Whistler we have to initialize the security descriptors
-       // This is not necessary under windows 98/95.
-       if (IsWindowsNT()) {
-               InitializeSecurityDescriptor(&sd,SECURITY_DESCRIPTOR_REVISION);
-               SetSecurityDescriptorDacl(&sd,TRUE,NULL,FALSE);
-               sa.bInheritHandle = TRUE;
-               sa.lpSecurityDescriptor = &sd;
-               lpsa = &sa;
-       }
-       memset(&startInfo,0,sizeof(STARTUPINFO));
-       startInfo.cb = sizeof(STARTUPINFO);
-       // Create a pipe for the child process's STDOUT.
-       if (! CreatePipe(&hChildStdoutRd, &hChildStdoutWr, &sa, 0))
-               return 0;
-       // Create a pipe for the child process's STDIN.
-       if (! CreatePipe(&hChildStdinRd, &hChildStdinWr, &sa, 0))
-               return 0;
-       // Setup the start info structure
-       startInfo.dwFlags = STARTF_USESTDHANDLES|STARTF_USESHOWWINDOW;
-       startInfo.wShowWindow = SW_HIDE;
-       startInfo.hStdOutput = hChildStdoutWr;
-       startInfo.hStdError = hChildStdoutWr;
-       startInfo.hStdInput = hChildStdinRd;
-       cmdline = OcamlPath;
-       // Set the OCAMLLIB environment variable
-       SetEnvironmentVariable("OCAMLLIB", LibDir);
-       // Let's go: start the ocaml interpreter
-       processStarted = CreateProcess(NULL,cmdline,lpsa,lpsa,1,
-               CREATE_NEW_PROCESS_GROUP|NORMAL_PRIORITY_CLASS,
-               NULL,ProgramParams.CurrentWorkingDir,&startInfo,&pi);
-       if (processStarted) {
-               WaitForSingleObject(pi.hProcess,INFINITE);
-               GetExitCodeProcess(pi.hProcess,(unsigned long *)&OcamlStatus);
-               CloseHandle(pi.hProcess);
-               PostMessage(hwndMain,WM_QUITOCAML,0,0);
-       }
-       else {
-               char *msg = malloc(1024);
-               wsprintf(msg,"Impossible to start ocaml.exe in:\n%s",cmdline);
-               ShowDbgMsg(msg);
-               free(msg);
-       }
-       return 0;
-}
-
-/*------------------------------------------------------------------------
-Procedure:     WriteToPipe ID:1
-Purpose:       Writes the given character string to the standard
-input of the interpreter
-Input:         The character string (zero terminated) to be written
-Output:        The number of characters written or zero if an error
-occurs
-Errors:        None
-------------------------------------------------------------------------*/
-int WriteToPipe(char *data)
-{
-       DWORD dwWritten;
-
-       if (! WriteFile(hChildStdinWr, data, strlen(data), &dwWritten, NULL))
-               return 0;
-
-       return dwWritten;
-
-}
-
-/*------------------------------------------------------------------------
-Procedure:     ReadFromPipe ID:1
-Purpose:       Reads from the standard output of the interpreter and
-stores the data in the given buffer up to the given
-length. This is done in a non-blocking manner, i.e.
-it is safe to call this even if there is no data
-available.
-Input:         The buffer to be used and its length.
-Output:        Returns the number of characters read from the pipe.
-Errors:        None explicit
-------------------------------------------------------------------------*/
-int ReadFromPipe(char *data,int len)
-{
-       DWORD dwRead;
-
-       PeekNamedPipe(hChildStdoutRd,data,len,NULL,&dwRead,NULL);
-       if (dwRead == 0)
-               return 0;
-
-       // Read output from the child process, and write to parent's STDOUT.
-       if( !ReadFile( hChildStdoutRd, data, len, &dwRead, NULL) || dwRead == 0)
-               return 0;
-
-       return dwRead;
-}
-
-static DWORD tid;
-/*------------------------------------------------------------------------
-Procedure:     StartOcaml ID:1
-Purpose:       Starts the thread that will call the ocaml.exe
-program.
-Input:
-Output:
-Errors:
-------------------------------------------------------------------------*/
-int StartOcaml(void)
-{
-       getcwd(ProgramParams.CurrentWorkingDir,sizeof(ProgramParams.CurrentWorkingDir));
-       CreateThread(NULL,0,DoStartOcaml,hwndMain,0,&tid);
-       return 1;
-}
-
-
-void *SafeMalloc(int size)
-{
-       void *result;
-
-       if (size < 0) {
-               char message[1024];
-
-error:
-               sprintf(message,"Can't allocate %d bytes",size);
-               MessageBox(NULL, message, "Ocaml", MB_OK);
-               exit(-1);
-       }
-       result = malloc(size);
-
-       if (result == NULL)
-               goto error;
-
-       return result;
-}
-
-
-void InterruptOcaml(void)
-{
-       if (!GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) {
-               char message[1024];
-               sprintf(message, "GenerateConsole failed: %lu\n", GetLastError());
-               MessageBox(NULL, message, "Ocaml", MB_OK);
-       }
-       WriteToPipe(" ");
-}

diff --git a/yacc/.cvsignore b/yacc/.cvsignore
deleted file mode 100644 (file)
index d7fa25c..0000000
--- a/yacc/.cvsignore
+++ /dev/null
@@ -1,5 +0,0 @@
-ocamlyacc
-*.c.x
-ocamlyacc.xcoff
-version.h
-.gdb_history

diff --git a/yacc/.ignore b/yacc/.ignore
new file mode 100644 (file)
index 0000000..bf37bf6
--- /dev/null
+++ b/yacc/.ignore
@@ -0,0 +1,3 @@
+ocamlyacc
+version.h
+.gdb_history

diff --git a/yacc/Makefile b/yacc/Makefile
index a90700f2fe463f577c508cd842ea9f101e5dd876..fb560cfd32d1ef93dbeb20e6d7d876dead13d16e 100644 (file)
--- a/yacc/Makefile
+++ b/yacc/Makefile
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt
index a33fa01430848064e8e0c571693a989fd62fafa9..14a69f02d72cc630b74fc8b53182bbc2cd876c13 100644 (file)
--- a/yacc/Makefile.nt
+++ b/yacc/Makefile.nt
@@ -1,6 +1,6 @@
 #########################################################################
 #                                                                       #
-#                            Objective Caml                             #
+#                                 OCaml                                 #
 #                                                                       #
 #            Xavier Leroy, projet Cristal, INRIA Rocquencourt           #
 #                                                                       #

diff --git a/yacc/closure.c b/yacc/closure.c
index 1b7926a07894392505b1ac69510f3a99de43403e..b3f4659d0187a60bac43f37ee26cd024a9466f25 100644 (file)
--- a/yacc/closure.c
+++ b/yacc/closure.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/defs.h b/yacc/defs.h
index 1be27d1a3f28d78b2280e51dca9435929b5a5be7..75c8ef101df8aeda29f103f77eb876f6262e6995 100644 (file)
--- a/yacc/defs.h
+++ b/yacc/defs.h
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/error.c b/yacc/error.c
index ae0b77aca188706499807938ac48f49be28049da..f0b92d2d6d7691ed1a97b4edbc6f4fdeb58266dd 100644 (file)
--- a/yacc/error.c
+++ b/yacc/error.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/lalr.c b/yacc/lalr.c
index f87afb1dc610f0c98d778e99527b3e5f1db938ca..d595e76d71e6bf54b1add51087330607e726b26c 100644 (file)
--- a/yacc/lalr.c
+++ b/yacc/lalr.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/lr0.c b/yacc/lr0.c
index e05fcb072a76f9cb387668f3c3f39fbc39f92ad6..3da50da00bf75918ccddddb60cf734389c22ac42 100644 (file)
--- a/yacc/lr0.c
+++ b/yacc/lr0.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/main.c b/yacc/main.c
index feb2dbdac516704780cc0ecb069ee92f6e9e52be..8616b9b3daf96efbe6a2ae926e6eba273aa8b986 100644 (file)
--- a/yacc/main.c
+++ b/yacc/main.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */
@@ -188,7 +188,7 @@ void getargs(int argc, char **argv)
 
         case 'v':
             if (!strcmp (argv[i], "-version")){
-              printf ("The Objective Caml parser generator, version "
+              printf ("The OCaml parser generator, version "
                       OCAML_VERSION "\n");
               exit (0);
             }else if (!strcmp (argv[i], "-vnum")){

diff --git a/yacc/mkpar.c b/yacc/mkpar.c
index 1f9759e1767915df9107ebafa9cb54f7988d6ab1..0e20724bf0f753de0e2a60d79c3fcd8039e9f86f 100644 (file)
--- a/yacc/mkpar.c
+++ b/yacc/mkpar.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/output.c b/yacc/output.c
index 00d61ac9c6ad8995eb55a16887bb3d40012a943e..9723d3fa675046e1af6de790fc788c9511ea74dd 100644 (file)
--- a/yacc/output.c
+++ b/yacc/output.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/reader.c b/yacc/reader.c
index d3c2755720ba9c1c514a23cddc7c656abf86a36e..1c36843d4447e3b65e913d88a9bf5b6daead5bfe 100644 (file)
--- a/yacc/reader.c
+++ b/yacc/reader.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/skeleton.c b/yacc/skeleton.c
index 86e152ac2d8961ed5713c5ff4eddb41b868f23b2..8048999d7d2d04c5ec979973a5f180c470b9761a 100644 (file)
--- a/yacc/skeleton.c
+++ b/yacc/skeleton.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/symtab.c b/yacc/symtab.c
index 87e280a09d66495834ae096fd5cd97146725ff49..f30e4a90d438a048ae672eeef321f93956f95404 100644 (file)
--- a/yacc/symtab.c
+++ b/yacc/symtab.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/verbose.c b/yacc/verbose.c
index 0a1850ff0faa153db6458b394f3db52b6504d00c..799c4969aa96a7602a8d4c880a2c95252782dd86 100644 (file)
--- a/yacc/verbose.c
+++ b/yacc/verbose.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */

diff --git a/yacc/warshall.c b/yacc/warshall.c
index 5b8f10c89ff70fae7da2c3ebc747692c39297284..c9ec782beb4a132b363e92a22e17b0de68e9b570 100644 (file)
--- a/yacc/warshall.c
+++ b/yacc/warshall.c
@@ -1,6 +1,6 @@
 /***********************************************************************/
 /*                                                                     */
-/*                           Objective Caml                            */
+/*                                OCaml                                */
 /*                                                                     */
 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
 /*                                                                     */